git.iko.soy/typeable/swagger2
on master help sign in
.ghcinew file+2
since splitsnapshots
unifiedsplit
@@ -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 @@
1dist
1dist
2+dist-newstyle
3+.ghc.environment.*
2cabal-dev
4cabal-dev
3*.o
5*.o
4*.hi
6*.hi
.travis.yml+155−34
@@ -1,41 +1,162 @@
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+#
1language: c
9language: c
2−
10+dist: xenial
3−# explicitly request container-based infrastructure
11+git:
12+ # whether to recursively clone submodules
4−sudo: false
13+ submodules: false
5−
14+branches:
15+ only:
16+ - master
17+cache:
18+ directories:
19+ - $HOME/.cabal/packages
20+ - $HOME/.cabal/store
21+before_cache:
22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
23+ # remove files that are regenerated by 'cabal update'
24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
26+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
27+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
28+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
29+ - rm -rfv $CABALHOME/packages/head.hackage
6matrix:
30matrix:
7 include:
31 include:
8− - env: CABALVER=1.18 GHCVER=7.8.4 HAPPYVER=1.19.4
32+ - compiler: ghc-8.8.1
9− addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.4], sources: [hvr-ghc]}}
33+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
10− - env: CABALVER=1.22 GHCVER=7.10.1 HAPPYVER=1.19.5
34+ - compiler: ghc-8.6.5
11− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5],sources: [hvr-ghc]}}
35+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
12− - env: CABALVER=head GHCVER=head HAPPYVER=head
36+ - compiler: ghc-8.4.4
13− addons: {apt: {packages: [cabal-install-head,ghc-head,happy-head], sources: [hvr-ghc]}}
37+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
14−
38+ - compiler: ghc-8.2.2
15− allow_failures:
39+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
16− - env: CABALVER=1.18 GHCVER=7.8.4 HAPPYVER=1.19.4
40+ - compiler: ghc-8.0.2
17− - env: CABALVER=head GHCVER=head HAPPYVER=head
41+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
18−
19before_install:
42before_install:
20− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH:/opt/happy/$HAPPYVER/bin
43+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
21−
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
22install:
74install:
23− - cabal --version
75+ - ${CABAL} --version
24− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
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
25− - travis_retry cabal update
110+ - travis_retry ${CABAL} v2-update -v
26− - cabal install --only-dependencies --enable-tests --enable-benchmarks
111+ # Generate cabal.project
27−
112+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
28−# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
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
29script:
126script:
30− - if [ -f configure.ac ]; then autoreconf -i; fi
127+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
31− - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
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...
32− - cabal build # this builds all libraries and executables (including tests/benchmarks)
146+ # this builds all libraries and executables (without tests/benchmarks)
33− - cabal test
147+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
34− - cabal check
148+ # Building with tests and benchmarks...
35− - cabal sdist # tests that a source-distribution can be generated
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
36
160
37−# Check that the resulting source distribution can be built & installed.
161+# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
38−# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
162+# EOF
39−# `cabal install --force-reinstalls dist/*-*.tar.gz`
40− - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
41− (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
CHANGELOG.md+276−6
@@ -1,3 +1,273 @@
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+
10.4.1
2710.4.1
2---
272---
3* Fixes:
273* Fixes:
@@ -15,7 +285,7 @@
15 * Fix `HasSchemaCommon` instance for `Schema`;
285 * Fix `HasSchemaCommon` instance for `Schema`;
16 * Change `minimum`, `maximum` and `multipleOf` properties to be any number,
286 * Change `minimum`, `maximum` and `multipleOf` properties to be any number,
17 not necessarily an integer;
287 not necessarily an integer;
18− * Fix all warnings
288+ * Fix all warnings.
19
289
200.3
2900.3
21---
291---
@@ -27,9 +297,9 @@
27
297
280.2
2980.2
29---
299---
30−* Add `Data.Swagger.Lens`
300+* Add `Data.Swagger.Lens`;
31−* Support references
301+* Support references;
32* Fixes:
302* Fixes:
33− * Fix `FromJSON SwaggerHost` instance
303+ * Fix `FromJSON SwaggerHost` instance;
34− * Add missing `Maybe`s for field types
304+ * Add missing `Maybe`s for field types;
35− * Decode petstore swagger.json successfully
305+ * Decode petstore `swagger.json` successfully.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015, GetShopTV
1+Copyright (c) 2015-2017, GetShopTV
2All rights reserved.
2All rights reserved.
3
3
4Redistribution and use in source and binary forms, with or without
4Redistribution and use in source and binary forms, with or without
README.md+33
@@ -1,6 +1,39 @@
1# swagger2
1# swagger2
2
2
3+[![Join the chat at https://gitter.im/haskell-swagger2/Lobby](https://badges.gitter.im/haskell-swagger2/Lobby.svg)](https://gitter.im/haskell-swagger2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
4+
3[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
5[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
4[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
6[![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)
5
9
6Swagger 2.0 data model.
10Swagger 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+
1import Distribution.Simple
28import Distribution.Simple
29+
30+main :: IO ()
2main = defaultMain
31main = 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+281−17
@@ -1,4 +1,9 @@
1+{-# LANGUAGE CPP #-}
1-- |
2-- |
3+-- Module: Data.Swagger
4+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5+-- Stability: experimental
6+--
2-- Swagger™ is a project used to describe and document RESTful APIs.
7-- Swagger™ is a project used to describe and document RESTful APIs.
3--
8--
4-- The Swagger specification defines a set of files required to describe such an API.
9-- The Swagger specification defines a set of files required to describe such an API.
@@ -6,81 +11,340 @@
6-- and Swagger-Codegen to generate clients in various languages.
11-- and Swagger-Codegen to generate clients in various languages.
7-- Additional utilities can also take advantage of the resulting files, such as testing tools.
12-- Additional utilities can also take advantage of the resulting files, such as testing tools.
8module Data.Swagger (
13module 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,
9 module Data.Swagger.ParamSchema,
36 module Data.Swagger.ParamSchema,
10 module Data.Swagger.Schema,
37 module Data.Swagger.Schema,
38+ module Data.Swagger.Schema.Validation,
11
39
12 -- * Swagger specification
40 -- * Swagger specification
13 Swagger(..),
41 Swagger(..),
14 Host(..),
42 Host(..),
15 Scheme(..),
43 Scheme(..),
16
44
17− -- * Info types
45+ -- ** Info types
18 Info(..),
46 Info(..),
19 Contact(..),
47 Contact(..),
20 License(..),
48 License(..),
21
49
22− -- * Paths
50+ -- ** PathItem
23− Paths(..),
24 PathItem(..),
51 PathItem(..),
25
52
26− -- * Operations
53+ -- ** Operations
27− Tag(..),
28 Operation(..),
54 Operation(..),
55+ Tag(..),
56+ TagName,
29
57
30− -- * Types and formats
58+ -- ** Types and formats
31 SwaggerType(..),
59 SwaggerType(..),
32 Format,
60 Format,
61+ Definitions,
33 CollectionFormat(..),
62 CollectionFormat(..),
34
63
35− -- * Parameters
64+ -- ** Parameters
36 Param(..),
65 Param(..),
37 ParamAnySchema(..),
66 ParamAnySchema(..),
38 ParamOtherSchema(..),
67 ParamOtherSchema(..),
39 ParamLocation(..),
68 ParamLocation(..),
40 ParamName,
69 ParamName,
41− Items(..),
42 Header(..),
70 Header(..),
71+ HeaderName,
43 Example(..),
72 Example(..),
44
73
45− -- * Schemas
74+ -- ** Schemas
46 ParamSchema(..),
75 ParamSchema(..),
47 Schema(..),
76 Schema(..),
48− SchemaItems(..),
77+ NamedSchema(..),
78+ SwaggerItems(..),
49 Xml(..),
79 Xml(..),
80+ Pattern,
81+ AdditionalProperties(..),
50
82
51− -- * Responses
83+ -- ** Responses
52 Responses(..),
84 Responses(..),
53 Response(..),
85 Response(..),
86+ HttpStatusCode,
54
87
55− -- * Security
88+ -- ** Security
56 SecurityScheme(..),
89 SecurityScheme(..),
57 SecuritySchemeType(..),
90 SecuritySchemeType(..),
58 SecurityRequirement(..),
91 SecurityRequirement(..),
92+ SecurityDefinitions(..),
59
93
60− -- ** API key
94+ -- *** API key
61 ApiKeyParams(..),
95 ApiKeyParams(..),
62 ApiKeyLocation(..),
96 ApiKeyLocation(..),
63
97
64− -- ** OAuth2
98+ -- *** OAuth2
65 OAuth2Params(..),
99 OAuth2Params(..),
66 OAuth2Flow(..),
100 OAuth2Flow(..),
67 AuthorizationURL,
101 AuthorizationURL,
68 TokenURL,
102 TokenURL,
69
103
70− -- * External documentation
104+ -- ** External documentation
71 ExternalDocs(..),
105 ExternalDocs(..),
72
106
73− -- * References
107+ -- ** References
74 Reference(..),
108 Reference(..),
75 Referenced(..),
109 Referenced(..),
76
110
77− -- * Miscellaneous
111+ -- ** Miscellaneous
78 MimeList(..),
112 MimeList(..),
79 URL(..),
113 URL(..),
80) where
114) where
81
115
116+import Data.Swagger.Lens
117+import Data.Swagger.Optics ()
118+import Data.Swagger.Operation
82import Data.Swagger.ParamSchema
119import Data.Swagger.ParamSchema
83import Data.Swagger.Schema
120import Data.Swagger.Schema
121+import Data.Swagger.Schema.Validation
84
122
85import Data.Swagger.Internal
123import Data.Swagger.Internal
86
124
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.hs+117−17
@@ -2,12 +2,33 @@
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+-- |
7+-- Module: Data.Swagger.Declare
8+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
9+-- Stability: experimental
10+--
11+-- Declare monad transformer and associated functions.
5module Data.Swagger.Declare where
12module Data.Swagger.Declare where
6
13
14+import Prelude ()
15+import Prelude.Compat
16+
7import Control.Monad
17import Control.Monad
18+import Control.Monad.Cont (ContT)
19+import Control.Monad.List (ListT)
20+import Control.Monad.Reader (ReaderT)
8import Control.Monad.Trans
21import 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
9import Data.Functor.Identity
31import Data.Functor.Identity
10−import Data.Monoid
11
32
12-- | A declare monad transformer parametrized by:
33-- | A declare monad transformer parametrized by:
13--
34--
@@ -24,54 +45,73 @@ import Data.Monoid
24newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
45newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
25 deriving (Functor)
46 deriving (Functor)
26
47
27−instance (Monad m, Monoid d) => Applicative (DeclareT d m) where
48+instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
28 pure x = DeclareT (\_ -> pure (mempty, x))
49 pure x = DeclareT (\_ -> pure (mempty, x))
29 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
50 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
30 ~(d', f) <- df d
51 ~(d', f) <- df d
31− ~(d'', x) <- dx (d <> d')
52+ ~(d'', x) <- dx (mappend d d')
32− return (d' <> d'', f x)
53+ return (mappend d' d'', f x)
33
54
34−instance (Monad m, Monoid d) => Monad (DeclareT d m) where
55+instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
35 return x = DeclareT (\_ -> pure (mempty, x))
56 return x = DeclareT (\_ -> pure (mempty, x))
36 DeclareT dx >>= f = DeclareT $ \d -> do
57 DeclareT dx >>= f = DeclareT $ \d -> do
37 ~(d', x) <- dx d
58 ~(d', x) <- dx d
38− ~(d'', y) <- runDeclareT (f x) (d <> d')
59+ ~(d'', y) <- runDeclareT (f x) (mappend d d')
39− return (d' <> d'', y)
60+ return (mappend d' d'', y)
40
61
41instance Monoid d => MonadTrans (DeclareT d) where
62instance Monoid d => MonadTrans (DeclareT d) where
42− lift m = DeclareT (\_ -> (,) mempty <$> m)
63+ lift m = DeclareT (\_ -> (,) mempty `liftM` m)
43
64
44-- |
65-- |
45−-- Laws:
66+-- Definitions of @declare@ and @look@ must satisfy the following laws:
46--
67--
47−-- @
68+-- [/monoid homomorphism (mempty)/]
48−-- declare mempty == return ()
69+-- @'declare' mempty == return ()@
49−-- declare x >> declare y == declare (x <> y)
50--
70--
51−-- declare x >> look == fmap (<> x) look <* declare x
71+-- [/monoid homomorphism (mappend)/]
72+-- @'declare' x >> 'declare' y == 'declare' (x <> y)@
73+-- for every @x@, @y@
52--
74--
53−-- look >> m == m
75+-- [/@declare@-@look@/]
54−-- @
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@
55−class Monad m => MonadDeclare d m | m -> d where
82+class (Applicative m, Monad m) => MonadDeclare d m | m -> d where
56 -- | @'declare' x@ is an action that produces the output @x@.
83 -- | @'declare' x@ is an action that produces the output @x@.
57 declare :: d -> m ()
84 declare :: d -> m ()
58 -- | @'look'@ is an action that returns all the output so far.
85 -- | @'look'@ is an action that returns all the output so far.
59 look :: m d
86 look :: m d
60
87
61−instance (Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
88+instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
62 declare d = DeclareT (\_ -> return (d, ()))
89 declare d = DeclareT (\_ -> return (d, ()))
63 look = DeclareT (\d -> return (mempty, d))
90 look = DeclareT (\d -> return (mempty, d))
64
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+
65-- | Retrieve a function of all the output so far.
99-- | Retrieve a function of all the output so far.
66looks :: MonadDeclare d m => (d -> a) -> m a
100looks :: MonadDeclare d m => (d -> a) -> m a
67looks f = f <$> look
101looks f = f <$> look
68
102
103+-- | Evaluate @'DeclareT' d m a@ computation,
104+-- ignoring new output @d@.
69evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
105evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
70evalDeclareT (DeclareT f) d = snd `liftM` f d
106evalDeclareT (DeclareT f) d = snd `liftM` f d
71
107
108+-- | Execute @'DeclateT' d m a@ computation,
109+-- ignoring result and only producing new output @d@.
72execDeclareT :: Monad m => DeclareT d m a -> d -> m d
110execDeclareT :: Monad m => DeclareT d m a -> d -> m d
73execDeclareT (DeclareT f) d = fst `liftM` f d
111execDeclareT (DeclareT f) d = fst `liftM` f d
74
112
113+-- | Evaluate @'DeclareT' d m a@ computation,
114+-- starting with empty output history.
75undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a
115undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a
76undeclareT = flip evalDeclareT mempty
116undeclareT = flip evalDeclareT mempty
77
117
@@ -85,15 +125,75 @@ undeclareT = flip evalDeclareT mempty
85-- * a writer monad with the extra ability to read all previous output.
125-- * a writer monad with the extra ability to read all previous output.
86type Declare d = DeclareT d Identity
126type Declare d = DeclareT d Identity
87
127
128+-- | Run @'Declare' d a@ computation with output history @d@,
129+-- producing result @a@ and new output @d@.
88runDeclare :: Declare d a -> d -> (d, a)
130runDeclare :: Declare d a -> d -> (d, a)
89runDeclare m = runIdentity . runDeclareT m
131runDeclare m = runIdentity . runDeclareT m
90
132
133+-- | Evaluate @'Declare' d a@ computation, ignoring output @d@.
91evalDeclare :: Declare d a -> d -> a
134evalDeclare :: Declare d a -> d -> a
92evalDeclare m = runIdentity . evalDeclareT m
135evalDeclare m = runIdentity . evalDeclareT m
93
136
137+-- | Execute @'Declate' d a@ computation, ignoring result and only
138+-- producing output @d@.
94execDeclare :: Declare d a -> d -> d
139execDeclare :: Declare d a -> d -> d
95execDeclare m = runIdentity . execDeclareT m
140execDeclare m = runIdentity . execDeclareT m
96
141
142+-- | Evaluate @'DeclareT' d m a@ computation,
143+-- starting with empty output history.
97undeclare :: Monoid d => Declare d a -> a
144undeclare :: Monoid d => Declare d a -> a
98undeclare = runIdentity . undeclareT
145undeclare = runIdentity . undeclareT
99
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+690−252
@@ -1,3 +1,7 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveFunctor #-}
1{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
@@ -9,88 +13,128 @@
9{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE StandaloneDeriving #-}
11{-# LANGUAGE TemplateHaskell #-}
15{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#if __GLASGOW_HASKELL__ <710
19+{-# LANGUAGE PolyKinds #-}
20+#endif
21+#include "overlapping-compat.h"
12module Data.Swagger.Internal where
22module Data.Swagger.Internal where
13
23
24+import Prelude ()
25+import Prelude.Compat
26+
27+import Control.Lens ((&), (.~), (?~))
14import Control.Applicative
28import Control.Applicative
15−import Control.Monad
16import Data.Aeson
29import Data.Aeson
17−import Data.Aeson.TH (deriveJSON)
30+import qualified Data.Aeson.Types as JSON
18−import Data.HashMap.Strict (HashMap)
31+import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32+import Data.Hashable (Hashable)
19import qualified Data.HashMap.Strict as HashMap
33import qualified Data.HashMap.Strict as HashMap
34+import Data.HashSet.InsOrd (InsOrdHashSet)
20import Data.Map (Map)
35import Data.Map (Map)
21import qualified Data.Map as Map
36import qualified Data.Map as Map
22−import Data.Monoid
37+import Data.Monoid (Monoid (..))
38+import Data.Semigroup.Compat (Semigroup (..))
23import Data.Scientific (Scientific)
39import Data.Scientific (Scientific)
24−import Data.String (fromString)
40+import Data.String (IsString(..))
25import Data.Text (Text)
41import Data.Text (Text)
26import qualified Data.Text as Text
42import qualified Data.Text as Text
27import GHC.Generics (Generic)
43import GHC.Generics (Generic)
28−import Network (HostName, PortNumber)
44+import Network.Socket (HostName, PortNumber)
29import Network.HTTP.Media (MediaType)
45import Network.HTTP.Media (MediaType)
30import Text.Read (readMaybe)
46import Text.Read (readMaybe)
31
47
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)
32import Data.Swagger.Internal.Utils
60import Data.Swagger.Internal.Utils
33
61
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+
34-- | This is the root document object for the API specification.
76-- | This is the root document object for the API specification.
35data Swagger = Swagger
77data Swagger = Swagger
36 { -- | Provides metadata about the API.
78 { -- | Provides metadata about the API.
37 -- The metadata can be used by the clients if needed.
79 -- The metadata can be used by the clients if needed.
38− _info :: Info
80+ _swaggerInfo :: Info
39
81
40 -- | The host (name or ip) serving the API. It MAY include a port.
82 -- | The host (name or ip) serving the API. It MAY include a port.
41 -- If the host is not included, the host serving the documentation is to be used (including the port).
83 -- If the host is not included, the host serving the documentation is to be used (including the port).
42− , _host :: Maybe Host
84+ , _swaggerHost :: Maybe Host
43
85
44 -- | The base path on which the API is served, which is relative to the host.
86 -- | The base path on which the API is served, which is relative to the host.
45 -- If it is not included, the API is served directly under the host.
87 -- If it is not included, the API is served directly under the host.
46 -- The value MUST start with a leading slash (/).
88 -- The value MUST start with a leading slash (/).
47− , _basePath :: Maybe FilePath
89+ , _swaggerBasePath :: Maybe FilePath
48
90
49 -- | The transfer protocol of the API.
91 -- | The transfer protocol of the API.
50 -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
92 -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
51− , _schemes :: Maybe [Scheme]
93+ , _swaggerSchemes :: Maybe [Scheme]
52
94
53 -- | A list of MIME types the APIs can consume.
95 -- | A list of MIME types the APIs can consume.
54 -- This is global to all APIs but can be overridden on specific API calls.
96 -- This is global to all APIs but can be overridden on specific API calls.
55− , _consumes :: MimeList
97+ , _swaggerConsumes :: MimeList
56
98
57 -- | A list of MIME types the APIs can produce.
99 -- | A list of MIME types the APIs can produce.
58− -- This is global to all APIs but can be overridden on specific API calls.
100+ -- This is global to all APIs but can be overridden on specific API calls.
59− , _produces :: MimeList
101+ , _swaggerProduces :: MimeList
60
102
61 -- | The available paths and operations for the API.
103 -- | The available paths and operations for the API.
62− , _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
63
107
64 -- | An object to hold data types produced and consumed by operations.
108 -- | An object to hold data types produced and consumed by operations.
65− , _definitions :: HashMap Text Schema
109+ , _swaggerDefinitions :: Definitions Schema
66
110
67 -- | An object to hold parameters that can be used across operations.
111 -- | An object to hold parameters that can be used across operations.
68 -- This property does not define global parameters for all operations.
112 -- This property does not define global parameters for all operations.
69− , _parameters :: HashMap Text Param
113+ , _swaggerParameters :: Definitions Param
70
114
71 -- | An object to hold responses that can be used across operations.
115 -- | An object to hold responses that can be used across operations.
72 -- This property does not define global responses for all operations.
116 -- This property does not define global responses for all operations.
73− , _responses :: HashMap Text Response
117+ , _swaggerResponses :: Definitions Response
74
118
75 -- | Security scheme definitions that can be used across the specification.
119 -- | Security scheme definitions that can be used across the specification.
76− , _securityDefinitions :: HashMap Text SecurityScheme
120+ , _swaggerSecurityDefinitions :: SecurityDefinitions
77
121
78 -- | A declaration of which security schemes are applied for the API as a whole.
122 -- | A declaration of which security schemes are applied for the API as a whole.
79 -- The list of values describes alternative security schemes that can be used
123 -- The list of values describes alternative security schemes that can be used
80 -- (that is, there is a logical OR between the security requirements).
124 -- (that is, there is a logical OR between the security requirements).
81 -- Individual operations can override this definition.
125 -- Individual operations can override this definition.
82− , _security :: [SecurityRequirement]
126+ , _swaggerSecurity :: [SecurityRequirement]
83
127
84 -- | A list of tags used by the specification with additional metadata.
128 -- | A list of tags used by the specification with additional metadata.
85 -- The order of the tags can be used to reflect on their order by the parsing tools.
129 -- The order of the tags can be used to reflect on their order by the parsing tools.
86 -- Not all tags that are used by the Operation Object must be declared.
130 -- Not all tags that are used by the Operation Object must be declared.
87 -- The tags that are not declared may be organized randomly or based on the tools' logic.
131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
88 -- Each tag name in the list MUST be unique.
132 -- Each tag name in the list MUST be unique.
89− , _tags :: [Tag]
133+ , _swaggerTags :: InsOrdHashSet Tag
90
134
91 -- | Additional external documentation.
135 -- | Additional external documentation.
92− , _externalDocs :: Maybe ExternalDocs
136+ , _swaggerExternalDocs :: Maybe ExternalDocs
93− } deriving (Eq, Show, Generic)
137+ } deriving (Eq, Show, Generic, Data, Typeable)
94
138
95-- | The object provides metadata about the API.
139-- | The object provides metadata about the API.
96-- The metadata can be used by the clients if needed,
140-- The metadata can be used by the clients if needed,
@@ -115,7 +159,7 @@ data Info = Info
115 -- | Provides the version of the application API
159 -- | Provides the version of the application API
116 -- (not to be confused with the specification version).
160 -- (not to be confused with the specification version).
117 , _infoVersion :: Text
161 , _infoVersion :: Text
118− } deriving (Eq, Show, Generic)
162+ } deriving (Eq, Show, Generic, Data, Typeable)
119
163
120-- | Contact information for the exposed API.
164-- | Contact information for the exposed API.
121data Contact = Contact
165data Contact = Contact
@@ -127,7 +171,7 @@ data Contact = Contact
127
171
128 -- | The email address of the contact person/organization.
172 -- | The email address of the contact person/organization.
129 , _contactEmail :: Maybe Text
173 , _contactEmail :: Maybe Text
130− } deriving (Eq, Show)
174+ } deriving (Eq, Show, Generic, Data, Typeable)
131
175
132-- | License information for the exposed API.
176-- | License information for the exposed API.
133data License = License
177data License = License
@@ -136,13 +180,32 @@ data License = License
136
180
137 -- | A URL to the license used for the API.
181 -- | A URL to the license used for the API.
138 , _licenseUrl :: Maybe URL
182 , _licenseUrl :: Maybe URL
139− } deriving (Eq, Show)
183+ } deriving (Eq, Show, Generic, Data, Typeable)
184+
185+instance IsString License where
186+ fromString s = License (fromString s) Nothing
140
187
141-- | The host (name or ip) serving the API. It MAY include a port.
188-- | The host (name or ip) serving the API. It MAY include a port.
142data Host = Host
189data Host = Host
143 { _hostName :: HostName -- ^ Host name.
190 { _hostName :: HostName -- ^ Host name.
144 , _hostPort :: Maybe PortNumber -- ^ Optional port.
191 , _hostPort :: Maybe PortNumber -- ^ Optional port.
145− } 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
146
209
147-- | The transfer protocol of the API.
210-- | The transfer protocol of the API.
148data Scheme
211data Scheme
@@ -150,14 +213,7 @@ data Scheme
150 | Https
213 | Https
151 | Ws
214 | Ws
152 | Wss
215 | Wss
153− deriving (Eq, Show)
216+ deriving (Eq, Show, Generic, Data, Typeable)
154−
155−-- | The available paths and operations for the API.
156−data Paths = Paths
157− { -- | Holds the relative paths to the individual endpoints.
158− -- The path is appended to the @'basePath'@ in order to construct the full URL.
159− _pathsMap :: HashMap FilePath PathItem
160− } deriving (Eq, Show, Generic)
161
217
162-- | Describes the operations available on a single path.
218-- | Describes the operations available on a single path.
163-- A @'PathItem'@ may be empty, due to ACL constraints.
219-- A @'PathItem'@ may be empty, due to ACL constraints.
@@ -190,13 +246,13 @@ data PathItem = PathItem
190 -- The list MUST NOT include duplicated parameters.
246 -- The list MUST NOT include duplicated parameters.
191 -- A unique parameter is defined by a combination of a name and location.
247 -- A unique parameter is defined by a combination of a name and location.
192 , _pathItemParameters :: [Referenced Param]
248 , _pathItemParameters :: [Referenced Param]
193− } deriving (Eq, Show, Generic)
249+ } deriving (Eq, Show, Generic, Data, Typeable)
194
250
195-- | Describes a single API operation on a path.
251-- | Describes a single API operation on a path.
196data Operation = Operation
252data Operation = Operation
197 { -- | A list of tags for API documentation control.
253 { -- | A list of tags for API documentation control.
198 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
199− _operationTags :: [Text]
255+ _operationTags :: InsOrdHashSet TagName
200
256
201 -- | A short summary of what the operation does.
257 -- | A short summary of what the operation does.
202 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -250,10 +306,23 @@ data Operation = Operation
250 -- This definition overrides any declared top-level security.
306 -- This definition overrides any declared top-level security.
251 -- To remove a top-level security declaration, @Just []@ can be used.
307 -- To remove a top-level security declaration, @Just []@ can be used.
252 , _operationSecurity :: [SecurityRequirement]
308 , _operationSecurity :: [SecurityRequirement]
253− } deriving (Eq, Show, Generic)
309+ } deriving (Eq, Show, Generic, Data, Typeable)
254
310
255newtype MimeList = MimeList { getMimeList :: [MediaType] }
311newtype MimeList = MimeList { getMimeList :: [MediaType] }
256− 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
257
326
258-- | Describes a single operation parameter.
327-- | Describes a single operation parameter.
259-- A unique parameter is defined by a combination of a name and location.
328-- A unique parameter is defined by a combination of a name and location.
@@ -274,12 +343,12 @@ data Param = Param
274
343
275 -- | Parameter schema.
344 -- | Parameter schema.
276 , _paramSchema :: ParamAnySchema
345 , _paramSchema :: ParamAnySchema
277− } deriving (Eq, Show, Generic)
346+ } deriving (Eq, Show, Generic, Data, Typeable)
278
347
279data ParamAnySchema
348data ParamAnySchema
280 = ParamBody (Referenced Schema)
349 = ParamBody (Referenced Schema)
281 | ParamOther ParamOtherSchema
350 | ParamOther ParamOtherSchema
282− deriving (Eq, Show)
351+ deriving (Eq, Show, Generic, Data, Typeable)
283
352
284data ParamOtherSchema = ParamOtherSchema
353data ParamOtherSchema = ParamOtherSchema
285 { -- | The location of the parameter.
354 { -- | The location of the parameter.
@@ -291,12 +360,92 @@ data ParamOtherSchema = ParamOtherSchema
291 -- Default value is @False@.
360 -- Default value is @False@.
292 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
361 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
293
362
294− -- | Determines the format of the array if @'ParamArray'@ is used.
295− -- Default value is csv.
296− , _paramOtherSchemaCollectionFormat :: Maybe (CollectionFormat Param)
297−
298− , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema Items
363+ , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
299− } deriving (Eq, Show, Generic)
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
300
449
301data SwaggerType t where
450data SwaggerType t where
302 SwaggerString :: SwaggerType t
451 SwaggerString :: SwaggerType t
@@ -304,13 +453,48 @@ data SwaggerType t where
304 SwaggerInteger :: SwaggerType t
453 SwaggerInteger :: SwaggerType t
305 SwaggerBoolean :: SwaggerType t
454 SwaggerBoolean :: SwaggerType t
306 SwaggerArray :: SwaggerType t
455 SwaggerArray :: SwaggerType t
307− SwaggerFile :: SwaggerType ParamOtherSchema
456+ SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
308− SwaggerNull :: SwaggerType Schema
457+ SwaggerNull :: SwaggerType 'SwaggerKindSchema
309− SwaggerObject :: SwaggerType Schema
458+ SwaggerObject :: SwaggerType 'SwaggerKindSchema
459+ deriving (Typeable)
310
460
311deriving instance Eq (SwaggerType t)
461deriving instance Eq (SwaggerType t)
312deriving instance Show (SwaggerType t)
462deriving instance Show (SwaggerType t)
313
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+
314data ParamLocation
498data ParamLocation
315 = -- | Parameters that are appended to the URL.
499 = -- | Parameters that are appended to the URL.
316 -- For example, in @/items?id=###@, the query parameter is @id@.
500 -- For example, in @/items?id=###@, the query parameter is @id@.
@@ -329,7 +513,7 @@ data ParamLocation
329 -- Form parameters have a different format based on the content-type used
513 -- Form parameters have a different format based on the content-type used
330 -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
514 -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
331 | ParamFormData
515 | ParamFormData
332− deriving (Eq, Show)
516+ deriving (Eq, Show, Generic, Data, Typeable)
333
517
334type Format = Text
518type Format = Text
335
519
@@ -346,11 +530,29 @@ data CollectionFormat t where
346 -- Corresponds to multiple parameter instances
530 -- Corresponds to multiple parameter instances
347 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
531 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
348 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
532 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
349− CollectionMulti :: CollectionFormat Param
533+ CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
534+ deriving (Typeable)
350
535
351deriving instance Eq (CollectionFormat t)
536deriving instance Eq (CollectionFormat t)
352deriving instance Show (CollectionFormat t)
537deriving instance Show (CollectionFormat t)
353
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)
555+
354type ParamName = Text
556type ParamName = Text
355
557
356data Schema = Schema
558data Schema = Schema
@@ -358,9 +560,9 @@ data Schema = Schema
358 , _schemaDescription :: Maybe Text
560 , _schemaDescription :: Maybe Text
359 , _schemaRequired :: [ParamName]
561 , _schemaRequired :: [ParamName]
360
562
361− , _schemaAllOf :: Maybe [Schema]
563+ , _schemaAllOf :: Maybe [Referenced Schema]
362− , _schemaProperties :: HashMap Text (Referenced Schema)
564+ , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
363− , _schemaAdditionalProperties :: Maybe Schema
565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties
364
566
365 , _schemaDiscriminator :: Maybe Text
567 , _schemaDiscriminator :: Maybe Text
366 , _schemaReadOnly :: Maybe Bool
568 , _schemaReadOnly :: Maybe Bool
@@ -371,15 +573,20 @@ data Schema = Schema
371 , _schemaMaxProperties :: Maybe Integer
573 , _schemaMaxProperties :: Maybe Integer
372 , _schemaMinProperties :: Maybe Integer
574 , _schemaMinProperties :: Maybe Integer
373
575
374− , _schemaParamSchema :: ParamSchema Schema SchemaItems
576+ , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
577+ } deriving (Eq, Show, Generic, Data, Typeable)
578+
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
375− } deriving (Eq, Show, Generic)
584+ } deriving (Eq, Show, Generic, Data, Typeable)
376
585
377−data SchemaItems
586+-- | Regex pattern for @string@ type.
378− = SchemaItemsObject (Referenced Schema)
587+type Pattern = Text
379− | SchemaItemsArray [Referenced Schema]
380− deriving (Eq, Show)
381
588
382−data ParamSchema t items = ParamSchema
589+data ParamSchema (t :: SwaggerKind *) = ParamSchema
383 { -- | Declares the value of the parameter that the server will use if none is provided,
590 { -- | Declares the value of the parameter that the server will use if none is provided,
384 -- for example a @"count"@ to control the number of results per page might default to @100@
591 -- for example a @"count"@ to control the number of results per page might default to @100@
385 -- if not supplied by the client in the request.
592 -- if not supplied by the client in the request.
@@ -387,26 +594,28 @@ data ParamSchema t items = ParamSchema
387 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
388 _paramSchemaDefault :: Maybe Value
595 _paramSchemaDefault :: Maybe Value
389
596
390− , _paramSchemaType :: SwaggerType t
597+ , _paramSchemaType :: Maybe (SwaggerType t)
391 , _paramSchemaFormat :: Maybe Format
598 , _paramSchemaFormat :: Maybe Format
392− , _paramSchemaItems :: Maybe items
599+ , _paramSchemaItems :: Maybe (SwaggerItems t)
393 , _paramSchemaMaximum :: Maybe Scientific
600 , _paramSchemaMaximum :: Maybe Scientific
394 , _paramSchemaExclusiveMaximum :: Maybe Bool
601 , _paramSchemaExclusiveMaximum :: Maybe Bool
395 , _paramSchemaMinimum :: Maybe Scientific
602 , _paramSchemaMinimum :: Maybe Scientific
396 , _paramSchemaExclusiveMinimum :: Maybe Bool
603 , _paramSchemaExclusiveMinimum :: Maybe Bool
397 , _paramSchemaMaxLength :: Maybe Integer
604 , _paramSchemaMaxLength :: Maybe Integer
398 , _paramSchemaMinLength :: Maybe Integer
605 , _paramSchemaMinLength :: Maybe Integer
399− , _paramSchemaPattern :: Maybe Text
606+ , _paramSchemaPattern :: Maybe Pattern
400 , _paramSchemaMaxItems :: Maybe Integer
607 , _paramSchemaMaxItems :: Maybe Integer
401 , _paramSchemaMinItems :: Maybe Integer
608 , _paramSchemaMinItems :: Maybe Integer
402 , _paramSchemaUniqueItems :: Maybe Bool
609 , _paramSchemaUniqueItems :: Maybe Bool
403 , _paramSchemaEnum :: Maybe [Value]
610 , _paramSchemaEnum :: Maybe [Value]
404 , _paramSchemaMultipleOf :: Maybe Scientific
611 , _paramSchemaMultipleOf :: Maybe Scientific
405− } deriving (Eq, Show, Generic)
612+ } deriving (Eq, Show, Generic, Typeable)
613+
614+deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
406
615
407data Xml = Xml
616data Xml = Xml
408 { -- | Replaces the name of the element/attribute used for the described schema property.
617 { -- | Replaces the name of the element/attribute used for the described schema property.
409− -- 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.
410 -- When defined alongside type being array (outside the items),
619 -- When defined alongside type being array (outside the items),
411 -- it will affect the wrapping element and only if wrapped is true.
620 -- it will affect the wrapping element and only if wrapped is true.
412 -- If wrapped is false, it will be ignored.
621 -- If wrapped is false, it will be ignored.
@@ -430,15 +639,7 @@ data Xml = Xml
430 -- Default value is @False@.
639 -- Default value is @False@.
431 -- The definition takes effect only when defined alongside type being array (outside the items).
640 -- The definition takes effect only when defined alongside type being array (outside the items).
432 , _xmlWrapped :: Maybe Bool
641 , _xmlWrapped :: Maybe Bool
433− } deriving (Eq, Show, Generic)
642+ } deriving (Eq, Show, Generic, Data, Typeable)
434−
435−data Items = Items
436− { -- | Determines the format of the array if type array is used.
437− -- Default value is @'ItemsCollectionCSV'@.
438− _itemsCollectionFormat :: Maybe (CollectionFormat Items)
439−
440− , _itemsParamSchema :: ParamSchema Items Items
441− } deriving (Eq, Show, Generic)
442
643
443-- | A container for the expected responses of an operation.
644-- | A container for the expected responses of an operation.
444-- The container maps a HTTP response code to the expected response.
645-- The container maps a HTTP response code to the expected response.
@@ -452,8 +653,8 @@ data Responses = Responses
452
653
453 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
654 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
454 -- Describes the expected response for those HTTP status codes.
655 -- Describes the expected response for those HTTP status codes.
455− , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
656+ , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
456− } deriving (Eq, Show, Generic)
657+ } deriving (Eq, Show, Generic, Data, Typeable)
457
658
458type HttpStatusCode = Int
659type HttpStatusCode = Int
459
660
@@ -471,11 +672,14 @@ data Response = Response
471 , _responseSchema :: Maybe (Referenced Schema)
672 , _responseSchema :: Maybe (Referenced Schema)
472
673
473 -- | A list of headers that are sent with the response.
674 -- | A list of headers that are sent with the response.
474− , _responseHeaders :: HashMap HeaderName Header
675+ , _responseHeaders :: InsOrdHashMap HeaderName Header
475
676
476 -- | An example of the response message.
677 -- | An example of the response message.
477 , _responseExamples :: Maybe Example
678 , _responseExamples :: Maybe Example
478− } 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
479
683
480type HeaderName = Text
684type HeaderName = Text
481
685
@@ -483,21 +687,30 @@ data Header = Header
483 { -- | A short description of the header.
687 { -- | A short description of the header.
484 _headerDescription :: Maybe Text
688 _headerDescription :: Maybe Text
485
689
486− -- | Determines the format of the array if type array is used.
487− -- Default value is @'ItemsCollectionCSV'@.
488− , _headerCollectionFormat :: Maybe (CollectionFormat Items)
489−
490− , _headerParamSchema :: ParamSchema Header Items
690+ , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
491− } deriving (Eq, Show, Generic)
691+ } deriving (Eq, Show, Generic, Data, Typeable)
492
692
493data Example = Example { getExample :: Map MediaType Value }
693data Example = Example { getExample :: Map MediaType Value }
494− deriving (Eq, Show)
694+ deriving (Eq, Show, Generic, Typeable)
695+
696+exampleConstr :: Constr
697+exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix
698+
699+exampleDataType :: DataType
700+exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]
701+
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
495
708
496-- | The location of the API key.
709-- | The location of the API key.
497data ApiKeyLocation
710data ApiKeyLocation
498 = ApiKeyQuery
711 = ApiKeyQuery
499 | ApiKeyHeader
712 | ApiKeyHeader
500− deriving (Eq, Show)
713+ deriving (Eq, Show, Generic, Data, Typeable)
501
714
502data ApiKeyParams = ApiKeyParams
715data ApiKeyParams = ApiKeyParams
503 { -- | The name of the header or query parameter to be used.
716 { -- | The name of the header or query parameter to be used.
@@ -505,7 +718,7 @@ data ApiKeyParams = ApiKeyParams
505
718
506 -- | The location of the API key.
719 -- | The location of the API key.
507 , _apiKeyIn :: ApiKeyLocation
720 , _apiKeyIn :: ApiKeyLocation
508− } deriving (Eq, Show)
721+ } deriving (Eq, Show, Generic, Data, Typeable)
509
722
510-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
723-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
511type AuthorizationURL = Text
724type AuthorizationURL = Text
@@ -518,21 +731,21 @@ data OAuth2Flow
518 | OAuth2Password TokenURL
731 | OAuth2Password TokenURL
519 | OAuth2Application TokenURL
732 | OAuth2Application TokenURL
520 | OAuth2AccessCode AuthorizationURL TokenURL
733 | OAuth2AccessCode AuthorizationURL TokenURL
521− deriving (Eq, Show)
734+ deriving (Eq, Show, Generic, Data, Typeable)
522
735
523data OAuth2Params = OAuth2Params
736data OAuth2Params = OAuth2Params
524 { -- | The flow used by the OAuth2 security scheme.
737 { -- | The flow used by the OAuth2 security scheme.
525 _oauth2Flow :: OAuth2Flow
738 _oauth2Flow :: OAuth2Flow
526
739
527 -- | The available scopes for the OAuth2 security scheme.
740 -- | The available scopes for the OAuth2 security scheme.
528− , _oauth2Scopes :: HashMap Text Text
741+ , _oauth2Scopes :: InsOrdHashMap Text Text
529− } deriving (Eq, Show, Generic)
742+ } deriving (Eq, Show, Generic, Data, Typeable)
530
743
531data SecuritySchemeType
744data SecuritySchemeType
532 = SecuritySchemeBasic
745 = SecuritySchemeBasic
533 | SecuritySchemeApiKey ApiKeyParams
746 | SecuritySchemeApiKey ApiKeyParams
534 | SecuritySchemeOAuth2 OAuth2Params
747 | SecuritySchemeOAuth2 OAuth2Params
535− deriving (Eq, Show)
748+ deriving (Eq, Show, Generic, Data, Typeable)
536
749
537data SecurityScheme = SecurityScheme
750data SecurityScheme = SecurityScheme
538 { -- | The type of the security scheme.
751 { -- | The type of the security scheme.
@@ -540,20 +753,39 @@ data SecurityScheme = SecurityScheme
540
753
541 -- | A short description for security scheme.
754 -- | A short description for security scheme.
542 , _securitySchemeDescription :: Maybe Text
755 , _securitySchemeDescription :: Maybe Text
543− } 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)
544
773
545-- | Lists the required security schemes to execute this operation.
774-- | Lists the required security schemes to execute this operation.
546-- The object can have multiple security schemes declared in it which are all required
775-- The object can have multiple security schemes declared in it which are all required
547-- (that is, there is a logical AND between the schemes).
776-- (that is, there is a logical AND between the schemes).
548newtype SecurityRequirement = SecurityRequirement
777newtype SecurityRequirement = SecurityRequirement
549− { getSecurityRequirement :: HashMap Text [Text]
778+ { getSecurityRequirement :: InsOrdHashMap Text [Text]
550− } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON)
779+ } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
780+
781+-- | Tag name.
782+type TagName = Text
551
783
552-- | Allows adding meta data to a single tag that is used by @Operation@.
784-- | Allows adding meta data to a single tag that is used by @Operation@.
553-- It is not mandatory to have a @Tag@ per tag used there.
785-- It is not mandatory to have a @Tag@ per tag used there.
554data Tag = Tag
786data Tag = Tag
555 { -- | The name of the tag.
787 { -- | The name of the tag.
556− _tagName :: Text
788+ _tagName :: TagName
557
789
558 -- | A short description for the tag.
790 -- | A short description for the tag.
559 -- GFM syntax can be used for rich text representation.
791 -- GFM syntax can be used for rich text representation.
@@ -561,7 +793,12 @@ data Tag = Tag
561
793
562 -- | Additional external documentation for this tag.
794 -- | Additional external documentation for this tag.
563 , _tagExternalDocs :: Maybe ExternalDocs
795 , _tagExternalDocs :: Maybe ExternalDocs
564− } 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
565
802
566-- | Allows referencing an external resource for extended documentation.
803-- | Allows referencing an external resource for extended documentation.
567data ExternalDocs = ExternalDocs
804data ExternalDocs = ExternalDocs
@@ -571,87 +808,145 @@ data ExternalDocs = ExternalDocs
571
808
572 -- | The URL for the target documentation.
809 -- | The URL for the target documentation.
573 , _externalDocsUrl :: URL
810 , _externalDocsUrl :: URL
574− } deriving (Eq, Show, Generic)
811+ } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812+
813+instance Hashable ExternalDocs
575
814
576-- | A simple object to allow referencing other definitions in the specification.
815-- | A simple object to allow referencing other definitions in the specification.
577-- It can be used to reference parameters and responses that are defined at the top level for reuse.
816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
578newtype Reference = Reference { getReference :: Text }
817newtype Reference = Reference { getReference :: Text }
579− deriving (Eq, Show)
818+ deriving (Eq, Show, Data, Typeable)
580
819
581data Referenced a
820data Referenced a
582 = Ref Reference
821 = Ref Reference
583 | Inline a
822 | Inline a
584− deriving (Eq, Show)
823+ deriving (Eq, Show, Functor, Data, Typeable)
824+
825+instance IsString a => IsString (Referenced a) where
826+ fromString = Inline . fromString
827+
828+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)
585
829
586−newtype URL = URL { getUrl :: Text } deriving (Eq, Show, ToJSON, FromJSON)
830+data AdditionalProperties
831+ = AdditionalPropertiesAllowed Bool
832+ | AdditionalPropertiesSchema (Referenced Schema)
833+ deriving (Eq, Show, Data, Typeable)
587
834
588-- =======================================================================
835-- =======================================================================
589-- Monoid instances
836-- Monoid instances
590-- =======================================================================
837-- =======================================================================
591
838
839+instance Semigroup Swagger where
840+ (<>) = genericMappend
592instance Monoid Swagger where
841instance Monoid Swagger where
593 mempty = genericMempty
842 mempty = genericMempty
594− mappend = genericMappend
843+ mappend = (<>)
595
844
845+instance Semigroup Info where
846+ (<>) = genericMappend
596instance Monoid Info where
847instance Monoid Info where
597 mempty = genericMempty
848 mempty = genericMempty
598− mappend = genericMappend
849+ mappend = (<>)
599
850
851+instance Semigroup Contact where
852+ (<>) = genericMappend
600−instance Monoid Paths where
853+instance Monoid Contact where
601 mempty = genericMempty
854 mempty = genericMempty
602− mappend = genericMappend
855+ mappend = (<>)
603
856
857+instance Semigroup PathItem where
858+ (<>) = genericMappend
604instance Monoid PathItem where
859instance Monoid PathItem where
605 mempty = genericMempty
860 mempty = genericMempty
606− mappend = genericMappend
861+ mappend = (<>)
607
862
863+instance Semigroup Schema where
864+ (<>) = genericMappend
608instance Monoid Schema where
865instance Monoid Schema where
609 mempty = genericMempty
866 mempty = genericMempty
610− mappend = genericMappend
867+ mappend = (<>)
611
868
869+instance Semigroup (ParamSchema t) where
870+ (<>) = genericMappend
612−instance Monoid (ParamSchema t i) where
871+instance Monoid (ParamSchema t) where
613 mempty = genericMempty
872 mempty = genericMempty
614− mappend = genericMappend
873+ mappend = (<>)
615
874
875+instance Semigroup Param where
876+ (<>) = genericMappend
616instance Monoid Param where
877instance Monoid Param where
617 mempty = genericMempty
878 mempty = genericMempty
618− mappend = genericMappend
879+ mappend = (<>)
619
880
881+instance Semigroup ParamOtherSchema where
882+ (<>) = genericMappend
620instance Monoid ParamOtherSchema where
883instance Monoid ParamOtherSchema where
621 mempty = genericMempty
884 mempty = genericMempty
622− mappend = genericMappend
885+ mappend = (<>)
623
886
887+instance Semigroup Header where
888+ (<>) = genericMappend
889+instance Monoid Header where
890+ mempty = genericMempty
891+ mappend = (<>)
892+
893+instance Semigroup Responses where
894+ (<>) = genericMappend
624instance Monoid Responses where
895instance Monoid Responses where
625 mempty = genericMempty
896 mempty = genericMempty
626− mappend = genericMappend
897+ mappend = (<>)
627
898
899+instance Semigroup Response where
900+ (<>) = genericMappend
628instance Monoid Response where
901instance Monoid Response where
629 mempty = genericMempty
902 mempty = genericMempty
630− mappend = genericMappend
903+ mappend = (<>)
631
904
905+instance Semigroup ExternalDocs where
906+ (<>) = genericMappend
632instance Monoid ExternalDocs where
907instance Monoid ExternalDocs where
633 mempty = genericMempty
908 mempty = genericMempty
634− mappend = genericMappend
909+ mappend = (<>)
635
910
911+instance Semigroup Operation where
912+ (<>) = genericMappend
636instance Monoid Operation where
913instance Monoid Operation where
637 mempty = genericMempty
914 mempty = genericMempty
915+ mappend = (<>)
916+
917+instance Semigroup Example where
638− mappend = genericMappend
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 = (<>)
639
933
640-- =======================================================================
934-- =======================================================================
641-- SwaggerMonoid helper instances
935-- SwaggerMonoid helper instances
642-- =======================================================================
936-- =======================================================================
643
937
644instance SwaggerMonoid Info
938instance SwaggerMonoid Info
645−instance SwaggerMonoid Paths
646instance SwaggerMonoid PathItem
939instance SwaggerMonoid PathItem
647instance SwaggerMonoid Schema
940instance SwaggerMonoid Schema
648−instance SwaggerMonoid (ParamSchema t i)
941+instance SwaggerMonoid (ParamSchema t)
649instance SwaggerMonoid Param
942instance SwaggerMonoid Param
650instance SwaggerMonoid ParamOtherSchema
943instance SwaggerMonoid ParamOtherSchema
651instance SwaggerMonoid Responses
944instance SwaggerMonoid Responses
652instance SwaggerMonoid Response
945instance SwaggerMonoid Response
653instance SwaggerMonoid ExternalDocs
946instance SwaggerMonoid ExternalDocs
654instance SwaggerMonoid Operation
947instance SwaggerMonoid Operation
948+instance SwaggerMonoid SecurityDefinitions
949+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
655
950
656instance SwaggerMonoid MimeList
951instance SwaggerMonoid MimeList
657deriving instance SwaggerMonoid URL
952deriving instance SwaggerMonoid URL
@@ -664,67 +959,85 @@ instance SwaggerMonoid ParamLocation where
664 swaggerMempty = ParamQuery
959 swaggerMempty = ParamQuery
665 swaggerMappend _ y = y
960 swaggerMappend _ y = y
666
961
667−instance SwaggerMonoid (HashMap Text Schema) where
962+instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
668− swaggerMempty = HashMap.empty
963+ swaggerMempty = InsOrdHashMap.empty
669− swaggerMappend = HashMap.unionWith mappend
964+ swaggerMappend = InsOrdHashMap.unionWith mappend
670−
671−instance SwaggerMonoid (HashMap Text (Referenced Schema)) where
672− swaggerMempty = HashMap.empty
673− swaggerMappend = HashMap.unionWith swaggerMappend
674
965
675instance Monoid a => SwaggerMonoid (Referenced a) where
966instance Monoid a => SwaggerMonoid (Referenced a) where
676 swaggerMempty = Inline mempty
967 swaggerMempty = Inline mempty
677− swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
968+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
678 swaggerMappend _ y = y
969 swaggerMappend _ y = y
679
970
680−instance SwaggerMonoid (HashMap Text Param) where
971+instance SwaggerMonoid ParamAnySchema where
681− swaggerMempty = HashMap.empty
972+ swaggerMempty = ParamOther swaggerMempty
682− swaggerMappend = HashMap.unionWith mappend
973+ swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
974+ swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
975+ swaggerMappend _ y = y
683
976
684−instance SwaggerMonoid (HashMap Text Response) where
977+-- =======================================================================
685− swaggerMempty = HashMap.empty
978+-- Simple Generic-based ToJSON instances
686− swaggerMappend = flip HashMap.union
979+-- =======================================================================
687
980
688−instance SwaggerMonoid (HashMap Text SecurityScheme) where
981+instance ToJSON ParamLocation where
689− swaggerMempty = HashMap.empty
982+ toJSON = genericToJSON (jsonPrefix "Param")
690− swaggerMappend = flip HashMap.union
691
983
692−instance SwaggerMonoid (HashMap FilePath PathItem) where
984+instance ToJSON Info where
693− swaggerMempty = HashMap.empty
985+ toJSON = genericToJSON (jsonPrefix "Info")
694− swaggerMappend = HashMap.unionWith mappend
695
986
696−instance SwaggerMonoid (HashMap HeaderName Header) where
987+instance ToJSON Contact where
697− swaggerMempty = HashMap.empty
988+ toJSON = genericToJSON (jsonPrefix "Contact")
698− swaggerMappend = flip HashMap.union
699
989
700−instance SwaggerMonoid (HashMap HttpStatusCode (Referenced Response)) where
990+instance ToJSON License where
701− swaggerMempty = HashMap.empty
991+ toJSON = genericToJSON (jsonPrefix "License")
702− swaggerMappend = flip HashMap.union
703
992
704−instance SwaggerMonoid ParamAnySchema where
993+instance ToJSON ApiKeyLocation where
705− swaggerMempty = ParamOther swaggerMempty
994+ toJSON = genericToJSON (jsonPrefix "ApiKey")
706− swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
995+
707− swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
996+instance ToJSON ApiKeyParams where
708− swaggerMappend _ y = y
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")
709
1010
710-- =======================================================================
1011-- =======================================================================
711−-- TH derived ToJSON and FromJSON instances
1012+-- Simple Generic-based FromJSON instances
712-- =======================================================================
1013-- =======================================================================
713
1014
714−deriveJSON (jsonPrefix "Param") ''ParamLocation
1015+instance FromJSON ParamLocation where
715−deriveJSON' ''Info
1016+ parseJSON = genericParseJSON (jsonPrefix "Param")
716−deriveJSON' ''Contact
1017+
717−deriveJSON' ''License
1018+instance FromJSON Info where
718−deriveJSON (jsonPrefix "ApiKey") ''ApiKeyLocation
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
719−deriveJSON (jsonPrefix "apiKey") ''ApiKeyParams
1031+ parseJSON = genericParseJSON (jsonPrefix "apiKey")
720−deriveJSONDefault ''Scheme
1032+
721−deriveJSON' ''Tag
1033+instance FromJSON Scheme where
722−deriveJSON' ''ExternalDocs
1034+ parseJSON = genericParseJSON (jsonPrefix "")
723−
1035+
724−deriveToJSON' ''Operation
1036+instance FromJSON Tag where
725−deriveToJSON' ''Response
1037+ parseJSON = genericParseJSON (jsonPrefix "Tag")
726−deriveToJSON' ''PathItem
1038+
727−deriveToJSON' ''Xml
1039+instance FromJSON ExternalDocs where
1040+ parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
728
1041
729-- =======================================================================
1042-- =======================================================================
730-- Manual ToJSON instances
1043-- Manual ToJSON instances
@@ -746,7 +1059,8 @@ instance ToJSON OAuth2Flow where
746 , "tokenUrl" .= tokenUrl ]
1059 , "tokenUrl" .= tokenUrl ]
747
1060
748instance ToJSON OAuth2Params where
1061instance ToJSON OAuth2Params where
749− toJSON = genericToJSONWithSub "flow" (jsonPrefix "oauth2")
1062+ toJSON = sopSwaggerGenericToJSON
1063+ DEFINE_TOENCODING
750
1064
751instance ToJSON SecuritySchemeType where
1065instance ToJSON SecuritySchemeType where
752 toJSON SecuritySchemeBasic
1066 toJSON SecuritySchemeBasic
@@ -759,22 +1073,38 @@ instance ToJSON SecuritySchemeType where
759 <+> object [ "type" .= ("oauth2" :: Text) ]
1073 <+> object [ "type" .= ("oauth2" :: Text) ]
760
1074
761instance ToJSON Swagger where
1075instance ToJSON Swagger where
762− toJSON = addVersion . genericToJSON (jsonPrefix "")
1076+ toJSON = sopSwaggerGenericToJSON
763− where
1077+ DEFINE_TOENCODING
764− addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
765− addVersion _ = error "impossible"
766
1078
767instance ToJSON SecurityScheme where
1079instance ToJSON SecurityScheme where
768− toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1080+ toJSON = sopSwaggerGenericToJSON
1081+ DEFINE_TOENCODING
769
1082
770instance ToJSON Schema where
1083instance ToJSON Schema where
771− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
1084+ toJSON = sopSwaggerGenericToJSON
1085+ DEFINE_TOENCODING
772
1086
773instance ToJSON Header where
1087instance ToJSON Header where
774− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
1088+ toJSON = sopSwaggerGenericToJSON
775−
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+--
776−instance ToJSON Items where
1097+instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
777− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "items")
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 ]
778
1108
779instance ToJSON Host where
1109instance ToJSON Host where
780 toJSON (Host host mport) = toJSON $
1110 toJSON (Host host mport) = toJSON $
@@ -782,38 +1112,53 @@ instance ToJSON Host where
782 Nothing -> host
1112 Nothing -> host
783 Just port -> host ++ ":" ++ show port
1113 Just port -> host ++ ":" ++ show port
784
1114
785−instance ToJSON Paths where
786− toJSON (Paths m) = toJSON m
787−
788instance ToJSON MimeList where
1115instance ToJSON MimeList where
789 toJSON (MimeList xs) = toJSON (map show xs)
1116 toJSON (MimeList xs) = toJSON (map show xs)
790
1117
791instance ToJSON Param where
1118instance ToJSON Param where
792− toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
1119+ toJSON = sopSwaggerGenericToJSON
1120+ DEFINE_TOENCODING
793
1121
794instance ToJSON ParamAnySchema where
1122instance ToJSON ParamAnySchema where
795 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1123 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
796 toJSON (ParamOther s) = toJSON s
1124 toJSON (ParamOther s) = toJSON s
797
1125
798instance ToJSON ParamOtherSchema where
1126instance ToJSON ParamOtherSchema where
799− toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1127+ toJSON = sopSwaggerGenericToJSON
800−
1128+ DEFINE_TOENCODING
801−instance ToJSON SchemaItems where
802− toJSON (SchemaItemsObject x) = toJSON x
803− toJSON (SchemaItemsArray xs) = toJSON xs
804
1129
805instance ToJSON Responses where
1130instance ToJSON Responses where
806− 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
807
1145
808instance ToJSON Example where
1146instance ToJSON Example where
809 toJSON = toJSON . Map.mapKeys show . getExample
1147 toJSON = toJSON . Map.mapKeys show . getExample
810
1148
1149+instance ToJSON SecurityDefinitions where
1150+ toJSON (SecurityDefinitions sd) = toJSON sd
1151+
811instance ToJSON Reference where
1152instance ToJSON Reference where
812 toJSON (Reference ref) = object [ "$ref" .= ref ]
1153 toJSON (Reference ref) = object [ "$ref" .= ref ]
813
1154
814−instance ToJSON a => ToJSON (Referenced a) where
1155+referencedToJSON :: ToJSON a => Text -> Referenced a -> Value
815− toJSON (Ref ref) = toJSON ref
1156+referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ]
816− toJSON (Inline x) = toJSON x
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/"
817
1162
818instance ToJSON (SwaggerType t) where
1163instance ToJSON (SwaggerType t) where
819 toJSON SwaggerArray = "array"
1164 toJSON SwaggerArray = "array"
@@ -832,8 +1177,14 @@ instance ToJSON (CollectionFormat t) where
832 toJSON CollectionPipes = "pipes"
1177 toJSON CollectionPipes = "pipes"
833 toJSON CollectionMulti = "multi"
1178 toJSON CollectionMulti = "multi"
834
1179
835−instance ToJSON i => ToJSON (ParamSchema t i) where
1180+instance ToJSON (ParamSchema k) where
836− toJSON = genericToJSON (jsonPrefix "paramSchema")
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
837
1188
838-- =======================================================================
1189-- =======================================================================
839-- Manual FromJSON instances
1190-- Manual FromJSON instances
@@ -853,7 +1204,7 @@ instance FromJSON OAuth2Flow where
853 parseJSON _ = empty
1204 parseJSON _ = empty
854
1205
855instance FromJSON OAuth2Params where
1206instance FromJSON OAuth2Params where
856− parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
1207+ parseJSON = sopSwaggerGenericParseJSON
857
1208
858instance FromJSON SecuritySchemeType where
1209instance FromJSON SecuritySchemeType where
859 parseJSON js@(Object o) = do
1210 parseJSON js@(Object o) = do
@@ -866,53 +1217,65 @@ instance FromJSON SecuritySchemeType where
866 parseJSON _ = empty
1217 parseJSON _ = empty
867
1218
868instance FromJSON Swagger where
1219instance FromJSON Swagger where
869− parseJSON js@(Object o) = do
1220+ parseJSON = sopSwaggerGenericParseJSON
870− (version :: Text) <- o .: "swagger"
871− when (version /= "2.0") empty
872− (genericParseJSON (jsonPrefix "")
873− `withDefaults` [ "consumes" .= (mempty :: MimeList)
874− , "produces" .= (mempty :: MimeList)
875− , "security" .= ([] :: [SecurityRequirement])
876− , "tags" .= ([] :: [Tag])
877− , "definitions" .= (mempty :: HashMap Text Schema)
878− , "parameters" .= (mempty :: HashMap Text Param)
879− , "responses" .= (mempty :: HashMap Text Response)
880− , "securityDefinitions" .= (mempty :: HashMap Text SecurityScheme)
881− ] ) js
882− parseJSON _ = empty
883
1221
884instance FromJSON SecurityScheme where
1222instance FromJSON SecurityScheme where
885− parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
1223+ parseJSON = sopSwaggerGenericParseJSON
886
1224
887instance FromJSON Schema where
1225instance FromJSON Schema where
888− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1226+ parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
889− `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1227+ where nullaryCleanup :: Schema -> Schema
890− , "required" .= ([] :: [ParamName]) ]
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
891
1233
892instance FromJSON Header where
1234instance FromJSON Header where
893− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
1235+ parseJSON = sopSwaggerGenericParseJSON
894−
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+
895−instance FromJSON Items where
1242+instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
896− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "items")
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
897
1264
898instance FromJSON Host where
1265instance FromJSON Host where
899− parseJSON (String s) =
1266+ parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of
900− case fromInteger <$> readMaybe portStr of
1267+ [host] -> return $ Host host Nothing
901− Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"
1268+ [host, port] -> case readMaybe port of
902− mport -> pure $ Host host mport
1269+ Nothing -> fail $ "Invalid port `" ++ port ++ "'"
903− where
1270+ Just p -> return $ Host host (Just (fromInteger p))
904− (hostText, portText) = Text.breakOn ":" s
1271+ _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'"
905− [host, portStr] = map Text.unpack [hostText, portText]
906 parseJSON _ = empty
1272 parseJSON _ = empty
907
1273
908−instance FromJSON Paths where
909− parseJSON js = Paths <$> parseJSON js
910−
911instance FromJSON MimeList where
1274instance FromJSON MimeList where
912 parseJSON js = (MimeList . map fromString) <$> parseJSON js
1275 parseJSON js = (MimeList . map fromString) <$> parseJSON js
913
1276
914instance FromJSON Param where
1277instance FromJSON Param where
915− parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
1278+ parseJSON = sopSwaggerGenericParseJSON
916
1279
917instance FromJSON ParamAnySchema where
1280instance FromJSON ParamAnySchema where
918 parseJSON js@(Object o) = do
1281 parseJSON js@(Object o) = do
@@ -925,17 +1288,12 @@ instance FromJSON ParamAnySchema where
925 parseJSON _ = empty
1288 parseJSON _ = empty
926
1289
927instance FromJSON ParamOtherSchema where
1290instance FromJSON ParamOtherSchema where
928− parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1291+ parseJSON = sopSwaggerGenericParseJSON
929−
930−instance FromJSON SchemaItems where
931− parseJSON js@(Object _) = SchemaItemsObject <$> parseJSON js
932− parseJSON js@(Array _) = SchemaItemsArray <$> parseJSON js
933− parseJSON _ = empty
934
1292
935instance FromJSON Responses where
1293instance FromJSON Responses where
936 parseJSON (Object o) = Responses
1294 parseJSON (Object o) = Responses
937 <$> o .:? "default"
1295 <$> o .:? "default"
938− <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
1296+ <*> (parseJSON (Object (HashMap.delete "default" o)))
939 parseJSON _ = empty
1297 parseJSON _ = empty
940
1298
941instance FromJSON Example where
1299instance FromJSON Example where
@@ -944,46 +1302,126 @@ instance FromJSON Example where
944 pure $ Example (Map.mapKeys fromString m)
1302 pure $ Example (Map.mapKeys fromString m)
945
1303
946instance FromJSON Response where
1304instance FromJSON Response where
947− parseJSON = genericParseJSON (jsonPrefix "response")
1305+ parseJSON = sopSwaggerGenericParseJSON
948− `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
949
1306
950instance FromJSON Operation where
1307instance FromJSON Operation where
951− parseJSON = genericParseJSON (jsonPrefix "operation")
1308+ parseJSON = sopSwaggerGenericParseJSON
952− `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]
953
1309
954instance FromJSON PathItem where
1310instance FromJSON PathItem where
955− parseJSON = genericParseJSON (jsonPrefix "pathItem")
1311+ parseJSON = sopSwaggerGenericParseJSON
956− `withDefaults` [ "parameters" .= ([] :: [Param]) ]
1312+
1313+instance FromJSON SecurityDefinitions where
1314+ parseJSON js = SecurityDefinitions <$> parseJSON js
957
1315
958instance FromJSON Reference where
1316instance FromJSON Reference where
959 parseJSON (Object o) = Reference <$> o .: "$ref"
1317 parseJSON (Object o) = Reference <$> o .: "$ref"
960 parseJSON _ = empty
1318 parseJSON _ = empty
961
1319
962−instance FromJSON a => FromJSON (Referenced a) where
1320+referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a)
963− parseJSON js
1321+referencedParseJSON prefix js@(Object o) = do
964− = Ref <$> parseJSON js
1322+ ms <- o .:? "$ref"
1323+ case ms of
965− <|> Inline <$> parseJSON js
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/"
966
1336
967instance FromJSON Xml where
1337instance FromJSON Xml where
968 parseJSON = genericParseJSON (jsonPrefix "xml")
1338 parseJSON = genericParseJSON (jsonPrefix "xml")
969
1339
970−instance FromJSON (SwaggerType Schema) where
1340+instance FromJSON (SwaggerType 'SwaggerKindSchema) where
971 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1341 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
972
1342
973−instance FromJSON (SwaggerType ParamOtherSchema) where
1343+instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
974 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1344 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
975
1345
976−instance {-# OVERLAPPABLE #-} FromJSON (SwaggerType t) where
1346+instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
977 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1347 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
978
1348
979−instance FromJSON (CollectionFormat Param) where
1349+instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
980− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
981−
982−instance FromJSON (CollectionFormat Items) where
983 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1350 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
984
1351
985−-- NOTE: The constraint @FromJSON (SwaggerType t)@ is necessary here!
1352+-- NOTE: There aren't collections of 'Schema'
986−-- Without the constraint the general instance will be used
1353+--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
987−-- that only accepts common types (i.e. NOT object, null or file).
1354+-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1355+
1356+instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where
1357+ parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1358+
988−instance (FromJSON (SwaggerType t), FromJSON i) => FromJSON (ParamSchema t i) where
1359+instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where
989− parseJSON = genericParseJSON (jsonPrefix "ParamSchema")
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.hs+176−43
@@ -1,31 +1,80 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PackageImports #-}
6{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
7{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE TypeSynonymInstances #-}
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"
10module Data.Swagger.Internal.ParamSchema where
22module Data.Swagger.Internal.ParamSchema where
11
23
12import Control.Lens
24import Control.Lens
13−import Data.Aeson
25+import Data.Aeson (ToJSON (..))
14import Data.Proxy
26import Data.Proxy
15import GHC.Generics
27import GHC.Generics
16
28
17import Data.Int
29import Data.Int
30+import "unordered-containers" Data.HashSet (HashSet)
18import Data.Monoid
31import Data.Monoid
32+import Data.Set (Set)
19import Data.Scientific
33import Data.Scientific
34+import Data.Fixed (HasResolution(..), Fixed, Pico)
20import qualified Data.Text as T
35import qualified Data.Text as T
21import qualified Data.Text.Lazy as TL
36import qualified Data.Text.Lazy as TL
22import Data.Time
37import 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)
23import Data.Word
44import Data.Word
45+import Data.UUID.Types (UUID)
46+import Web.Cookie (SetCookie)
24
47
25import Data.Swagger.Internal
48import Data.Swagger.Internal
26import Data.Swagger.Lens
49import Data.Swagger.Lens
27import Data.Swagger.SchemaOptions
50import Data.Swagger.SchemaOptions
28
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+
29-- | Convert a type into a plain @'ParamSchema'@.
78-- | Convert a type into a plain @'ParamSchema'@.
30--
79--
31-- An example type and instance:
80-- An example type and instance:
@@ -38,9 +87,9 @@ import Data.Swagger.SchemaOptions
38-- data Direction = Up | Down
87-- data Direction = Up | Down
39--
88--
40-- instance ToParamSchema Direction where
89-- instance ToParamSchema Direction where
41−-- toParamSchema = mempty
90+-- toParamSchema _ = mempty
42−-- & schemaType .~ SwaggerString
91+-- & type_ ?~ SwaggerString
43−-- & schemaEnum .~ [ \"Up\", \"Down\" ]
92+-- & enum_ ?~ [ \"Up\", \"Down\" ]
44-- @
93-- @
45--
94--
46-- Instead of manually writing your @'ToParamSchema'@ instance you can
95-- Instead of manually writing your @'ToParamSchema'@ instance you can
@@ -63,24 +112,37 @@ import Data.Swagger.SchemaOptions
63-- @
112-- @
64class ToParamSchema a where
113class ToParamSchema a where
65 -- | Convert a type into a plain parameter schema.
114 -- | Convert a type into a plain parameter schema.
115+ --
116+ -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
117+ -- "{\"type\":\"integer\"}"
66− toParamSchema :: proxy a -> ParamSchema t i
118+ toParamSchema :: Proxy a -> ParamSchema t
67− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t i
119+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
68 toParamSchema = genericToParamSchema defaultSchemaOptions
120 toParamSchema = genericToParamSchema defaultSchemaOptions
69
121
70−instance {-# OVERLAPPING #-} ToParamSchema String where
122+instance OVERLAPPING_ ToParamSchema String where
71− toParamSchema _ = mempty & schemaType .~ SwaggerString
123+ toParamSchema _ = mempty & type_ ?~ SwaggerString
72
124
73instance ToParamSchema Bool where
125instance ToParamSchema Bool where
74− toParamSchema _ = mempty & schemaType .~ SwaggerBoolean
126+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
75
127
76instance ToParamSchema Integer where
128instance ToParamSchema Integer where
77− toParamSchema _ = mempty & schemaType .~ SwaggerInteger
129+ toParamSchema _ = mempty & type_ ?~ SwaggerInteger
130+
131+instance ToParamSchema Natural where
132+ toParamSchema _ = mempty
133+ & type_ ?~ SwaggerInteger
134+ & minimum_ ?~ 0
135+ & exclusiveMinimum ?~ False
78
136
79instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
137instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
80instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
138instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
81instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral
139instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral
140+
82−instance ToParamSchema Int32 where toParamSchema = toParamSchemaBoundedIntegral
141+instance ToParamSchema Int32 where
142+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"
143+
83−instance ToParamSchema Int64 where toParamSchema = toParamSchemaBoundedIntegral
144+instance ToParamSchema Int64 where
145+ toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"
84
146
85instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
147instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
86instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
148instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -89,59 +151,74 @@ instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
89instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
151instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
90
152
91-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
153-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
154+--
155+-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156+-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
92−toParamSchemaBoundedIntegral :: forall proxy a t i. (Bounded a, Integral a) => proxy a -> ParamSchema t i
157+toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
93toParamSchemaBoundedIntegral _ = mempty
158toParamSchemaBoundedIntegral _ = mempty
94− & schemaType .~ SwaggerInteger
159+ & type_ ?~ SwaggerInteger
95− & schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
160+ & minimum_ ?~ fromInteger (toInteger (minBound :: a))
96− & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a))
161+ & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
97
162
98instance ToParamSchema Char where
163instance ToParamSchema Char where
99 toParamSchema _ = mempty
164 toParamSchema _ = mempty
100− & schemaType .~ SwaggerString
165+ & type_ ?~ SwaggerString
101− & schemaMaxLength ?~ 1
166+ & maxLength ?~ 1
102− & schemaMinLength ?~ 1
167+ & minLength ?~ 1
103
168
104instance ToParamSchema Scientific where
169instance ToParamSchema Scientific where
105− toParamSchema _ = mempty & schemaType .~ SwaggerNumber
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))
106
176
107instance ToParamSchema Double where
177instance ToParamSchema Double where
108− toParamSchema _ = mempty & schemaType .~ SwaggerNumber
178+ toParamSchema _ = mempty
179+ & type_ ?~ SwaggerNumber
180+ & format ?~ "double"
109
181
110instance ToParamSchema Float where
182instance ToParamSchema Float where
111− toParamSchema _ = mempty & schemaType .~ SwaggerNumber
183+ toParamSchema _ = mempty
184+ & type_ ?~ SwaggerNumber
185+ & format ?~ "float"
112
186
113−timeParamSchema :: String -> ParamSchema t i
187+timeParamSchema :: String -> ParamSchema t
114−timeParamSchema format = mempty
188+timeParamSchema fmt = mempty
115− & schemaType .~ SwaggerString
189+ & type_ ?~ SwaggerString
116− & schemaFormat ?~ T.pack format
190+ & format ?~ T.pack fmt
117− & schemaMinLength ?~ toInteger (length format)
118
191
119−-- |
192+-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
120−-- >>> toParamSchema (Proxy :: Proxy Day) ^. schemaFormat
121−-- Just "yyyy-mm-dd"
122instance ToParamSchema Day where
193instance ToParamSchema Day where
123− toParamSchema _ = timeParamSchema "yyyy-mm-dd"
194+ toParamSchema _ = timeParamSchema "date"
124
195
125-- |
196-- |
126−-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
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
127-- Just "yyyy-mm-ddThh:MM:ss"
204-- Just "yyyy-mm-ddThh:MM:ss"
128instance ToParamSchema LocalTime where
205instance ToParamSchema LocalTime where
129 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss"
206 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss"
130
207
131-- |
208-- |
132−-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
209+-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
133-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
210-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
134instance ToParamSchema ZonedTime where
211instance ToParamSchema ZonedTime where
135 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
212 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
136
213
137-- |
214-- |
138−-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
215+-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
139-- Just "yyyy-mm-ddThh:MM:ssZ"
216-- Just "yyyy-mm-ddThh:MM:ssZ"
140instance ToParamSchema UTCTime where
217instance ToParamSchema UTCTime where
141 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
218 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
142
219
143instance ToParamSchema NominalDiffTime where
220instance ToParamSchema NominalDiffTime where
144− toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
221+ toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
145
222
146instance ToParamSchema T.Text where
223instance ToParamSchema T.Text where
147 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
224 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -149,6 +226,28 @@ instance ToParamSchema T.Text where
149instance ToParamSchema TL.Text where
226instance ToParamSchema TL.Text where
150 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
227 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
151
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+
152instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
251instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
153instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
252instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
154instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
253instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
@@ -157,24 +256,56 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
157instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
256instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
158instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
257instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
159
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+
160-- |
278-- |
161−-- >>> encode (toParamSchema (Proxy :: Proxy ()) :: ParamSchema t Items)
279+-- >>> encode $ toParamSchema (Proxy :: Proxy ())
162-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
280-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
163instance ToParamSchema () where
281instance ToParamSchema () where
164 toParamSchema _ = mempty
282 toParamSchema _ = mempty
165− & schemaType .~ SwaggerString
283+ & type_ ?~ SwaggerString
166− & schemaEnum ?~ ["_"]
284+ & enum_ ?~ ["_"]
285+
286+instance ToParamSchema UUID where
287+ toParamSchema _ = mempty
288+ & type_ ?~ SwaggerString
289+ & format ?~ "uuid"
167
290
168-- | A configurable generic @'ParamSchema'@ creator.
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\"]}"
169−genericToParamSchema :: forall proxy a t i. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t i
297+genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
170genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
298genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
171
299
172class GToParamSchema (f :: * -> *) where
300class GToParamSchema (f :: * -> *) where
173− gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i
301+ gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
174
302
175instance GToParamSchema f => GToParamSchema (D1 d f) where
303instance GToParamSchema f => GToParamSchema (D1 d f) where
176 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
304 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
177
305
306+instance Constructor c => GToParamSchema (C1 c U1) where
307+ gtoParamSchema = genumParamSchema
308+
178instance GToParamSchema f => GToParamSchema (C1 c (S1 s f)) where
309instance GToParamSchema f => GToParamSchema (C1 c (S1 s f)) where
179 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
310 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
180
311
@@ -185,15 +316,15 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
185 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
316 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
186
317
187class GEnumParamSchema (f :: * -> *) where
318class GEnumParamSchema (f :: * -> *) where
188− genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t i -> ParamSchema t i
319+ genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
189
320
190instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
321instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
191 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
322 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
192
323
193instance Constructor c => GEnumParamSchema (C1 c U1) where
324instance Constructor c => GEnumParamSchema (C1 c U1) where
194 genumParamSchema opts _ s = s
325 genumParamSchema opts _ s = s
195− & schemaType .~ SwaggerString
326+ & type_ ?~ SwaggerString
196− & schemaEnum %~ addEnumValue tag
327+ & enum_ %~ addEnumValue tag
197 where
328 where
198 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
329 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
199
330
@@ -202,3 +333,5 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
202
333
203data Proxy3 a b c = Proxy3
334data Proxy3 a b c = Proxy3
204
335
336+-- $setup
337+-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hs+650−221
@@ -1,7 +1,10 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE OverloadedLists #-}
8{-# LANGUAGE OverloadedLists #-}
6{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PackageImports #-}
10{-# LANGUAGE PackageImports #-}
@@ -11,57 +14,84 @@
11{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeSynonymInstances #-}
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"
14module Data.Swagger.Internal.Schema where
25module Data.Swagger.Internal.Schema where
15
26
27+import Prelude ()
28+import Prelude.Compat
29+
16import Control.Lens
30import Control.Lens
31+import Data.Data.Lens (template)
32+
17import Control.Monad
33import Control.Monad
18import Control.Monad.Writer
34import Control.Monad.Writer
19−import Data.Aeson
35+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
20import Data.Char
36import Data.Char
37+import Data.Data (Data)
38+import Data.Foldable (traverse_)
21import Data.HashMap.Strict (HashMap)
39import Data.HashMap.Strict (HashMap)
22import qualified Data.HashMap.Strict as HashMap
40import qualified Data.HashMap.Strict as HashMap
23−import "unordered-containers" Data.HashSet (HashSet)
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
24import Data.Int
44import Data.Int
25import Data.IntSet (IntSet)
45import Data.IntSet (IntSet)
26import Data.IntMap (IntMap)
46import Data.IntMap (IntMap)
47+import Data.List.NonEmpty.Compat (NonEmpty)
27import Data.Map (Map)
48import Data.Map (Map)
28−import Data.Monoid
29import Data.Proxy
49import Data.Proxy
30import Data.Scientific (Scientific)
50import Data.Scientific (Scientific)
51+import Data.Fixed (Fixed, HasResolution, Pico)
31import Data.Set (Set)
52import Data.Set (Set)
32import qualified Data.Text as T
53import qualified Data.Text as T
33import qualified Data.Text.Lazy as TL
54import qualified Data.Text.Lazy as TL
34import Data.Time
55import 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)
35import Data.Word
62import Data.Word
36import GHC.Generics
63import GHC.Generics
64+import qualified Data.UUID.Types as UUID
37
65
38import Data.Swagger.Declare
66import Data.Swagger.Declare
39import Data.Swagger.Internal
67import Data.Swagger.Internal
40import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
68import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
41−import Data.Swagger.Lens
69+import Data.Swagger.Lens hiding (name, schema)
70+import qualified Data.Swagger.Lens as Swagger
42import Data.Swagger.SchemaOptions
71import Data.Swagger.SchemaOptions
72+import Data.Swagger.Internal.TypeShape
43
73
44−-- | A @'Schema'@ with an optional name.
74+#if __GLASGOW_HASKELL__ < 800
45−-- This name can be used in references.
75+#else
46−type NamedSchema = (Maybe String, Schema)
76+import qualified Data.ByteString as BS
47−
77+import qualified Data.ByteString.Lazy as BSL
48−-- | Schema definitions, a mapping from schema name to @'Schema'@.
78+import GHC.TypeLits (TypeError, ErrorMessage(..))
49−type Definitions = HashMap T.Text Schema
79+#endif
50
80
51unnamed :: Schema -> NamedSchema
81unnamed :: Schema -> NamedSchema
52−unnamed schema = (Nothing, schema)
82+unnamed schema = NamedSchema Nothing schema
53
83
54−named :: String -> Schema -> NamedSchema
84+named :: T.Text -> Schema -> NamedSchema
55−named name schema = (Just name, schema)
85+named name schema = NamedSchema (Just name) schema
56
86
57−plain :: Schema -> Declare Definitions NamedSchema
87+plain :: Schema -> Declare (Definitions Schema) NamedSchema
58plain = pure . unnamed
88plain = pure . unnamed
59
89
60unname :: NamedSchema -> NamedSchema
90unname :: NamedSchema -> NamedSchema
61−unname (_, schema) = (Nothing, schema)
91+unname (NamedSchema _ schema) = unnamed schema
62
92
63−rename :: Maybe String -> NamedSchema -> NamedSchema
93+rename :: Maybe T.Text -> NamedSchema -> NamedSchema
64−rename name (_, schema) = (name, schema)
94+rename name (NamedSchema _ schema) = NamedSchema name schema
65
95
66-- | Convert a type into @'Schema'@.
96-- | Convert a type into @'Schema'@.
67--
97--
@@ -72,27 +102,29 @@ rename name (_, schema) = (name, schema)
72-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
102-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
73--
103--
74-- import Control.Lens
104-- import Control.Lens
105+-- import Data.Proxy
106+-- import Data.Swagger
75--
107--
76-- data Coord = Coord { x :: Double, y :: Double }
108-- data Coord = Coord { x :: Double, y :: Double }
77--
109--
78-- instance ToSchema Coord where
110-- instance ToSchema Coord where
79−-- toSchemaDefinitions = pure (Just "Coord", schema)
111+-- declareNamedSchema _ = do
80−-- where
112+-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
81−-- schema = mempty
113+-- return $ NamedSchema (Just \"Coord\") $ mempty
82−-- & schemaType .~ SwaggerObject
114+-- & type_ ?~ SwaggerObject
83−-- & schemaProperties .~
115+-- & properties .~
84−-- [ ("x", toSchemaRef (Proxy :: Proxy Double))
116+-- [ (\"x\", doubleSchema)
85−-- , ("y", toSchemaRef (Proxy :: Proxy Double))
117+-- , (\"y\", doubleSchema)
86−-- ]
118+-- ]
87−-- & schemaRequired .~ [ "x", "y" ]
119+-- & required .~ [ \"x\", \"y\" ]
88-- @
120-- @
89--
121--
90-- Instead of manually writing your @'ToSchema'@ instance you can
122-- Instead of manually writing your @'ToSchema'@ instance you can
91−-- use a default generic implementation of @'toSchemaDefinitions'@.
123+-- use a default generic implementation of @'declareNamedSchema'@.
92--
124--
93-- To do that, simply add @deriving 'Generic'@ clause to your datatype
125-- To do that, simply add @deriving 'Generic'@ clause to your datatype
94-- and declare a @'ToSchema'@ instance for your datatype without
126-- and declare a @'ToSchema'@ instance for your datatype without
95−-- giving definition for @'toSchemaDefinitions'@.
127+-- giving definition for @'declareNamedSchema'@.
96--
128--
97-- For instance, the previous example can be simplified into this:
129-- For instance, the previous example can be simplified into this:
98--
130--
@@ -110,76 +142,325 @@ class ToSchema a where
110 -- together with all used definitions.
142 -- together with all used definitions.
111 -- Note that the schema itself is included in definitions
143 -- Note that the schema itself is included in definitions
112 -- only if it is recursive (and thus needs its definition in scope).
144 -- only if it is recursive (and thus needs its definition in scope).
113− toSchemaDefinitions :: proxy a -> Declare Definitions NamedSchema
145+ declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
146+ default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
114− default toSchemaDefinitions :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare Definitions NamedSchema
147+ Proxy a -> Declare (Definitions Schema) NamedSchema
115− toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
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
116
157
117-- | Convert a type into an optionally named schema.
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\"}"
118−toNamedSchema :: ToSchema a => proxy a -> NamedSchema
169+toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
119−toNamedSchema = undeclare . toSchemaDefinitions
170+toNamedSchema = undeclare . declareNamedSchema
120
171
121-- | Get type's schema name according to its @'ToSchema'@ instance.
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"
122−schemaName :: ToSchema a => proxy a -> Maybe String
179+schemaName :: ToSchema a => Proxy a -> Maybe T.Text
123−schemaName = fst . toNamedSchema
180+schemaName = _namedSchemaName . toNamedSchema
124
181
125-- | Convert a type into a schema.
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\"}"
126−toSchema :: ToSchema a => proxy a -> Schema
189+toSchema :: ToSchema a => Proxy a -> Schema
127−toSchema = snd . toNamedSchema
190+toSchema = _namedSchemaSchema . toNamedSchema
128−
129−declareSchema :: ToSchema a => proxy a -> Declare Definitions Schema
130−declareSchema = fmap snd . toSchemaDefinitions
131
191
132-- | Convert a type into a referenced schema if possible.
192-- | Convert a type into a referenced schema if possible.
133−-- Only named schemas can be references, nameless schemas are inlined.
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\"}"
134−toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
200+toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
135toSchemaRef = undeclare . declareSchemaRef
201toSchemaRef = undeclare . declareSchemaRef
136
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).
137−declareSchemaRef :: ToSchema a => proxy a -> Declare Definitions (Referenced Schema)
210+declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
138declareSchemaRef proxy = do
211declareSchemaRef proxy = do
139 case toNamedSchema proxy of
212 case toNamedSchema proxy of
140− (Just name, schema) -> do
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.
141− known <- looks (HashMap.member (T.pack name))
222+ known <- looks (InsOrdHashMap.member name)
142 when (not known) $ do
223 when (not known) $ do
143− declare [(T.pack name, schema)]
224+ declare [(name, schema)]
144− void $ toSchemaDefinitions proxy
225+ void $ declareNamedSchema proxy
145− return $ Ref (Reference ("#/definitions/" <> T.pack name))
226+ return $ Ref (Reference name)
146 _ -> Inline <$> declareSchema proxy
227 _ -> Inline <$> declareSchema proxy
147
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+
148class GToSchema (f :: * -> *) where
416class GToSchema (f :: * -> *) where
149− gtoSchemaDefinitions :: SchemaOptions -> proxy f -> Schema -> Declare Definitions NamedSchema
417+ gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
150
418
151−instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
419+instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
152− toSchemaDefinitions _ = do
420+ declareNamedSchema _ = do
153 ref <- declareSchemaRef (Proxy :: Proxy a)
421 ref <- declareSchemaRef (Proxy :: Proxy a)
154 return $ unnamed $ mempty
422 return $ unnamed $ mempty
155− & schemaType .~ SwaggerArray
423+ & type_ ?~ SwaggerArray
156− & schemaItems ?~ SchemaItemsObject ref
424+ & items ?~ SwaggerItemsObject ref
157−
425+
158−instance {-# OVERLAPPING #-} ToSchema String where toSchemaDefinitions = plain . paramSchemaToSchema
426+instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
159−instance ToSchema Bool where toSchemaDefinitions = plain . paramSchemaToSchema
427+instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
160−instance ToSchema Integer where toSchemaDefinitions = plain . paramSchemaToSchema
428+instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429+instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
161−instance ToSchema Int where toSchemaDefinitions = plain . paramSchemaToSchema
430+instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
162−instance ToSchema Int8 where toSchemaDefinitions = plain . paramSchemaToSchema
431+instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
163−instance ToSchema Int16 where toSchemaDefinitions = plain . paramSchemaToSchema
432+instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
164−instance ToSchema Int32 where toSchemaDefinitions = plain . paramSchemaToSchema
433+instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
165−instance ToSchema Int64 where toSchemaDefinitions = plain . paramSchemaToSchema
434+instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
166−instance ToSchema Word where toSchemaDefinitions = plain . paramSchemaToSchema
435+instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
167−instance ToSchema Word8 where toSchemaDefinitions = plain . paramSchemaToSchema
436+instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
168−instance ToSchema Word16 where toSchemaDefinitions = plain . paramSchemaToSchema
437+instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
169−instance ToSchema Word32 where toSchemaDefinitions = plain . paramSchemaToSchema
438+instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
170−instance ToSchema Word64 where toSchemaDefinitions = plain . paramSchemaToSchema
439+instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
171−
440+
172−instance ToSchema Char where toSchemaDefinitions = plain . paramSchemaToSchema
441+instance ToSchema Char where
442+ declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
443+ & mapped.Swagger.schema.example ?~ toJSON '?'
444+
173−instance ToSchema Scientific where toSchemaDefinitions = plain . paramSchemaToSchema
445+instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
174−instance ToSchema Double where toSchemaDefinitions = plain . paramSchemaToSchema
446+instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
175−instance ToSchema Float where toSchemaDefinitions = plain . paramSchemaToSchema
447+instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448+
449+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
176
450
177instance ToSchema a => ToSchema (Maybe a) where
451instance ToSchema a => ToSchema (Maybe a) where
178− toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy a)
452+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
179
453
180instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
454instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
181
455
182−instance ToSchema ()
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+
183instance (ToSchema a, ToSchema b) => ToSchema (a, b)
464instance (ToSchema a, ToSchema b) => ToSchema (a, b)
184instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
465instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
185instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
466instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
@@ -187,254 +468,398 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchem
187instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
468instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
188instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
469instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
189
470
190−timeSchema :: String -> Schema
471+timeSchema :: T.Text -> Schema
191−timeSchema format = mempty
472+timeSchema fmt = mempty
192− & schemaType .~ SwaggerString
473+ & type_ ?~ SwaggerString
193− & schemaFormat ?~ T.pack format
474+ & format ?~ fmt
194− & schemaMinLength ?~ toInteger (length format)
195
475
196−-- |
476+-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
197−-- >>> toSchema (Proxy :: Proxy Day) ^. schemaFormat
198−-- Just "yyyy-mm-dd"
199instance ToSchema Day where
477instance ToSchema Day where
200− toSchemaDefinitions _ = pure $ named "Day" (timeSchema "yyyy-mm-dd")
478+ declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
479+ & example ?~ toJSON (fromGregorian 2016 7 22)
201
480
202-- |
481-- |
203−-- >>> toSchema (Proxy :: Proxy LocalTime) ^. schemaFormat
482+-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
204-- Just "yyyy-mm-ddThh:MM:ss"
483-- Just "yyyy-mm-ddThh:MM:ss"
205instance ToSchema LocalTime where
484instance ToSchema LocalTime where
206− toSchemaDefinitions _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
485+ declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
486+ & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
207
487
208−-- |
209−-- >>> toSchema (Proxy :: Proxy ZonedTime) ^. schemaFormat
210−-- Just "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
488+-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
211instance ToSchema ZonedTime where
489instance ToSchema ZonedTime where
212− toSchemaDefinitions _ = pure $ named "ZonedTime" $ timeSchema "yyyy-mm-ddThh:MM:ss(Z|+hh:MM)"
490+ declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
213− & schemaMinLength ?~ toInteger (length ("yyyy-mm-ddThh:MM:ssZ" :: String))
491+ & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
214
492
215instance ToSchema NominalDiffTime where
493instance ToSchema NominalDiffTime where
216− toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy Integer)
494+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
217
495
218-- |
496-- |
219−-- >>> toSchema (Proxy :: Proxy UTCTime) ^. schemaFormat
497+-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
220-- Just "yyyy-mm-ddThh:MM:ssZ"
498-- Just "yyyy-mm-ddThh:MM:ssZ"
221instance ToSchema UTCTime where
499instance ToSchema UTCTime where
222− toSchemaDefinitions _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
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
223
505
224−instance ToSchema T.Text where toSchemaDefinitions = plain . paramSchemaToSchema
506+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
225−instance ToSchema TL.Text where toSchemaDefinitions = plain . paramSchemaToSchema
226
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+
227−instance ToSchema IntSet where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Set Int))
520+instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
228
521
229-- | NOTE: This schema does not account for the uniqueness of keys.
522-- | NOTE: This schema does not account for the uniqueness of keys.
230instance ToSchema a => ToSchema (IntMap a) where
523instance ToSchema a => ToSchema (IntMap a) where
231− toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy [(Int, a)])
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
232
542
233instance ToSchema a => ToSchema (Map String a) where
543instance ToSchema a => ToSchema (Map String a) where
234− toSchemaDefinitions _ = do
544+ declareNamedSchema _ = do
235− schema <- declareSchema (Proxy :: Proxy a)
545+ schema <- declareSchemaRef (Proxy :: Proxy a)
236 return $ unnamed $ mempty
546 return $ unnamed $ mempty
237− & schemaType .~ SwaggerObject
547+ & type_ ?~ SwaggerObject
238− & schemaAdditionalProperties ?~ schema
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))
239
556
240−instance ToSchema a => ToSchema (Map T.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
557+#endif
241−instance ToSchema a => ToSchema (Map TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
242
558
243−instance ToSchema a => ToSchema (HashMap String a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
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])
244−instance ToSchema a => ToSchema (HashMap T.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String a))
566+instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
245−instance ToSchema a => ToSchema (HashMap TL.Text a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Map String 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])
246
569
247instance ToSchema a => ToSchema (Set a) where
570instance ToSchema a => ToSchema (Set a) where
248− toSchemaDefinitions _ = do
571+ declareNamedSchema _ = do
249 schema <- declareSchema (Proxy :: Proxy [a])
572 schema <- declareSchema (Proxy :: Proxy [a])
250 return $ unnamed $ schema
573 return $ unnamed $ schema
251− & schemaUniqueItems ?~ True
574+ & uniqueItems ?~ True
252
575
253−instance ToSchema a => ToSchema (HashSet a) where toSchemaDefinitions _ = toSchemaDefinitions (Proxy :: Proxy (Set a))
576+instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
254
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+
255−instance ToSchema All where toSchemaDefinitions = plain . paramSchemaToSchema
585+instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
256−instance ToSchema Any where toSchemaDefinitions = plain . paramSchemaToSchema
586+instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
257
587
258−instance ToSchema a => ToSchema (Sum a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
588+instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
259−instance ToSchema a => ToSchema (Product a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
589+instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
260−instance ToSchema a => ToSchema (First a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
590+instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
261−instance ToSchema a => ToSchema (Last a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
591+instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
262−instance ToSchema a => ToSchema (Dual a) where toSchemaDefinitions _ = unname <$> toSchemaDefinitions (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)
263
595
264-- | Default schema for @'Bounded'@, @'Integral'@ types.
596-- | Default schema for @'Bounded'@, @'Integral'@ types.
597+--
598+-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599+-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
265−toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
600+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
266toSchemaBoundedIntegral _ = mempty
601toSchemaBoundedIntegral _ = mempty
267− & schemaType .~ SwaggerInteger
602+ & type_ ?~ SwaggerInteger
268− & schemaMinimum ?~ fromInteger (toInteger (minBound :: a))
603+ & minimum_ ?~ fromInteger (toInteger (minBound :: a))
269− & schemaMaximum ?~ fromInteger (toInteger (maxBound :: a))
604+ & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
270
605
271-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
272−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
607+genericToNamedSchemaBoundedIntegral :: forall a d f.
273 ( Bounded a, Integral a
608 ( Bounded a, Integral a
274 , Generic a, Rep a ~ D1 d f, Datatype d)
609 , Generic a, Rep a ~ D1 d f, Datatype d)
275− => SchemaOptions -> proxy a -> NamedSchema
610+ => SchemaOptions -> Proxy a -> NamedSchema
276genericToNamedSchemaBoundedIntegral opts proxy
611genericToNamedSchemaBoundedIntegral opts proxy
277− = (gdatatypeSchemaName opts (Proxy :: Proxy d), toSchemaBoundedIntegral 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
278
668
279-- | A configurable generic @'Schema'@ creator.
669-- | A configurable generic @'Schema'@ creator.
280−genericToSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Schema
670+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
281−genericToSchema opts = snd . genericToNamedSchema opts
671+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
672+genericDeclareSchema = genericDeclareSchemaUnrestricted
282
673
283-- | A configurable generic @'NamedSchema'@ creator.
674-- | A configurable generic @'NamedSchema'@ creator.
284−genericToNamedSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> NamedSchema
285−genericToNamedSchema opts = undeclare . genericToSchemaDefinitions opts
286−
287−-- | A configurable generic @'NamedSchema'@ creator with declarations.
288-- This function applied to @'defaultSchemaOptions'@
675-- This function applied to @'defaultSchemaOptions'@
289−-- is used as the default for @'toSchemaDefinitions'@
676+-- is used as the default for @'declareNamedSchema'@
290-- when the type is an instance of @'Generic'@.
677-- when the type is an instance of @'Generic'@.
678+genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
291−genericToSchemaDefinitions :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare Definitions NamedSchema
679+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
292−genericToSchemaDefinitions opts _ = gtoSchemaDefinitions opts (Proxy :: Proxy (Rep a)) mempty
680+genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
293
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+
294−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe String
703+gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
295−gdatatypeSchemaName opts _ = case name of
704+gdatatypeSchemaName opts _ = case orig of
296− (c:_) | isAlpha c && isUpper c -> Just name
705+ (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
297 _ -> Nothing
706 _ -> Nothing
298 where
707 where
299− name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
708+ orig = datatypeName (Proxy3 :: Proxy3 d f a)
709+ name = datatypeNameModifier opts orig
300
710
301-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
302−paramSchemaToNamedSchema :: forall a d f proxy.
303− (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
712+paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
304− => SchemaOptions -> proxy a -> NamedSchema
713+ SchemaOptions -> Proxy a -> NamedSchema
305−paramSchemaToNamedSchema opts proxy = (gdatatypeSchemaName opts (Proxy :: Proxy d), paramSchemaToSchema proxy)
714+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
306
715
307-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
308−paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
717+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
309−paramSchemaToSchema _ = mempty & schemaParamSchema .~ toParamSchema (Proxy :: Proxy a)
718+paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
310
719
311nullarySchema :: Schema
720nullarySchema :: Schema
312nullarySchema = mempty
721nullarySchema = mempty
313− & schemaType .~ SwaggerArray
722+ & type_ ?~ SwaggerArray
314− & schemaEnum ?~ [ toJSON () ]
723+ & items ?~ SwaggerItemsArray []
315−
316−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
317−gtoNamedSchema opts proxy = undeclare $ gtoSchemaDefinitions opts proxy mempty
318−
319−gtoSchema :: GToSchema f => SchemaOptions -> proxy f -> Schema
320−gtoSchema opts = snd . gtoNamedSchema opts
321
724
322−gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare Definitions Schema
725+gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
323−gdeclareSchema opts proxy = snd <$> gtoSchemaDefinitions opts proxy mempty
726+gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
324
727
325−gschemaName :: GToSchema f => SchemaOptions -> proxy f -> Maybe String
728+gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
326−gschemaName opts = fst . gtoNamedSchema opts
729+gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
327−
328−instance GToSchema U1 where
329− gtoSchemaDefinitions _ _ _ = plain nullarySchema
330
730
331instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
332− gtoSchemaDefinitions opts _ schema = do
732+ gdeclareNamedSchema opts _ schema = do
333− (_, gschema) <- gtoSchemaDefinitions opts (Proxy :: Proxy g) schema
733+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
334− gtoSchemaDefinitions opts (Proxy :: Proxy f) gschema
734+ gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
335
735
336instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
736instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
337− gtoSchemaDefinitions opts _ s = rename name <$> gtoSchemaDefinitions opts (Proxy :: Proxy f) s
737+ gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
338 where
738 where
339 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
739 name = gdatatypeSchemaName opts (Proxy :: Proxy d)
340
740
341−instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
741+instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where
342− gtoSchemaDefinitions opts _ = gtoSchemaDefinitions opts (Proxy :: Proxy f)
742+ gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
743+
744+instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745+ gdeclareNamedSchema = gdeclareNamedSumSchema
343
746
344-- | Single field constructor.
747-- | Single field constructor.
345−instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
748+instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
346− gtoSchemaDefinitions opts _ s
749+ gdeclareNamedSchema opts _ s
347 | unwrapUnaryRecords opts = fieldSchema
750 | unwrapUnaryRecords opts = fieldSchema
348− | otherwise = do
751+ | otherwise =
349− (_, schema) <- recordSchema
350− case schema ^. schemaItems of
752+ case schema ^. items of
351− Just (SchemaItemsArray [_]) -> fieldSchema
753+ Just (SwaggerItemsArray [_]) -> fieldSchema
754+ _ -> do
755+ declare defs
352− _ -> pure (unnamed schema)
756+ return (unnamed schema)
353 where
757 where
354− recordSchema = gtoSchemaDefinitions opts (Proxy :: Proxy (S1 s f)) s
758+ (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
759+ recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
355− fieldSchema = gtoSchemaDefinitions opts (Proxy :: Proxy f) s
760+ fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
356
761
357−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare Definitions (Referenced Schema)
762+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
358gdeclareSchemaRef opts proxy = do
763gdeclareSchemaRef opts proxy = do
359 case gtoNamedSchema opts proxy of
764 case gtoNamedSchema opts proxy of
360− (Just name, schema) -> do
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.
361− known <- looks (HashMap.member (T.pack name))
774+ known <- looks (InsOrdHashMap.member name)
362 when (not known) $ do
775 when (not known) $ do
363− declare [(T.pack name, schema)]
776+ declare [(name, schema)]
364− void $ gtoSchemaDefinitions opts proxy mempty
777+ void $ gdeclareNamedSchema opts proxy mempty
365− return $ Ref (Reference ("#/definitions/" <> T.pack name))
778+ return $ Ref (Reference name)
366 _ -> Inline <$> gdeclareSchema opts proxy
779 _ -> Inline <$> gdeclareSchema opts proxy
367
780
368−appendItem :: Referenced Schema -> Maybe SchemaItems -> Maybe SchemaItems
781+appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
369−appendItem x Nothing = Just (SchemaItemsArray [x])
782+appendItem x Nothing = Just (SwaggerItemsArray [x])
370−appendItem x (Just (SchemaItemsArray xs)) = Just (SchemaItemsArray (x:xs))
783+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
371−appendItem _ _ = error "GToSchema.appendItem: cannot append to SchemaItemsObject"
784+appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
372
785
373withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
786withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
374− SchemaOptions -> proxy s f -> Bool -> Schema -> Declare Definitions Schema
787+ SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
375withFieldSchema opts _ isRequiredField schema = do
788withFieldSchema opts _ isRequiredField schema = do
376 ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
789 ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
377 return $
790 return $
378 if T.null fname
791 if T.null fname
379 then schema
792 then schema
380− & schemaType .~ SwaggerArray
793+ & type_ ?~ SwaggerArray
381− & schemaItems %~ appendItem ref
794+ & items %~ appendItem ref
795+ & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796+ & minItems %~ Just . maybe 1 (+1) -- increment minItems
382 else schema
797 else schema
383− & schemaType .~ SwaggerObject
798+ & type_ ?~ SwaggerObject
384− & schemaProperties . at fname ?~ ref
799+ & properties . at fname ?~ ref
385 & if isRequiredField
800 & if isRequiredField
386− then schemaRequired %~ (fname :)
801+ then required %~ (++ [fname])
387 else id
802 else id
388 where
803 where
389 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
804 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
390
805
391-- | Optional record fields.
806-- | Optional record fields.
392−instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
807+instance OVERLAPPING_ (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
393− gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
808+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
394
809
395-- | Record fields.
810-- | Record fields.
396−instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
811+instance OVERLAPPABLE_ (Selector s, GToSchema f) => GToSchema (S1 s f) where
397− gtoSchemaDefinitions opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
812+ gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
398
813
399−instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
814+instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
400− gtoSchemaDefinitions _ _ _ = toSchemaDefinitions (Proxy :: Proxy c)
815+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
401
816
402−instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
817+instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
403− gtoSchemaDefinitions _ _ _ = toSchemaDefinitions (Proxy :: Proxy c)
818+ gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
404
819
405−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
820+instance ( GSumToSchema f
406− gtoSchemaDefinitions opts _ s
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
407− | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
828+ | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
408− | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
829+ | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
409− where
830+ where
410− declareSumSchema = gsumToSchema opts (Proxy :: Proxy (f :+: g)) s
831+ declareSumSchema = gsumToSchema opts proxy s
411− (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
832+ (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
412
833
413− toStringTag schema = mempty
834+ toStringTag schema = mempty
414− & schemaType .~ SwaggerString
835+ & type_ ?~ SwaggerString
415− & schemaEnum ?~ map toJSON (schema ^.. schemaProperties.ifolded.asIndex)
836+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
416
837
417type AllNullary = All
838type AllNullary = All
418
839
419−class GSumToSchema f where
840+class GSumToSchema (f :: * -> *) where
420− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare Definitions) Schema
841+ gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
421
842
422instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
423− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
844+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
424−
845+
425−gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
846+gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
426− SchemaOptions -> proxy (C1 c f) -> Schema -> Declare Definitions Schema
847+ Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
427−gsumConToSchema opts _ schema = do
848+gsumConToSchemaWith ref opts _ schema = schema
428− ref <- gdeclareSchemaRef opts (Proxy :: Proxy (C1 c f))
429− return $ schema
430− & schemaType .~ SwaggerObject
849+ & type_ ?~ SwaggerObject
431− & schemaProperties . at tag ?~ ref
850+ & properties . at tag ?~ ref
432− & schemaMaxProperties ?~ 1
851+ & maxProperties ?~ 1
433− & schemaMinProperties ?~ 1
852+ & minProperties ?~ 1
434 where
853 where
435 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
436
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+
437−instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
862+instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
438 gsumToSchema opts proxy schema = do
863 gsumToSchema opts proxy schema = do
439 tell (All False)
864 tell (All False)
440 lift $ gsumConToSchema opts proxy schema
865 lift $ gsumConToSchema opts proxy schema
@@ -445,9 +870,13 @@ instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)
445 lift $ gsumConToSchema opts proxy schema
870 lift $ gsumConToSchema opts proxy schema
446
871
447instance Constructor c => GSumToSchema (C1 c U1) where
872instance Constructor c => GSumToSchema (C1 c U1) where
448− gsumToSchema opts proxy = lift . gsumConToSchema opts proxy
873+ gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy
449
874
450data Proxy2 a b = Proxy2
875data Proxy2 a b = Proxy2
451
876
452data Proxy3 a b c = Proxy3
877data Proxy3 a b c = Proxy3
453
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+46−43
@@ -1,34 +1,55 @@
1{-# LANGUAGE DefaultSignatures #-}
1{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
5module Data.Swagger.Internal.Utils where
7module Data.Swagger.Internal.Utils where
6
8
7−import Control.Arrow (first)
9+import Prelude ()
10+import Prelude.Compat
11+
12+import Control.Lens ((&), (%~))
8−import Control.Applicative
13+import Control.Lens.TH
9import Data.Aeson
14import Data.Aeson
10−import Data.Aeson.TH
15+import Data.Aeson.Types
11−import Data.Aeson.Types (Parser, Pair)
12import Data.Char
16import Data.Char
17+import Data.Data
13import Data.Hashable (Hashable)
18import Data.Hashable (Hashable)
14import Data.HashMap.Strict (HashMap)
19import Data.HashMap.Strict (HashMap)
15import qualified Data.HashMap.Strict as HashMap
20import 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)
17import Data.Text (Text)
25import Data.Text (Text)
18import GHC.Generics
26import GHC.Generics
19−import Language.Haskell.TH
27+import Language.Haskell.TH (mkName)
20−import Text.Read (readMaybe)
21−
22−hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
23−hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
24
28
25−hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
29+swaggerFieldRules :: LensRules
26−hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
30+swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
27 where
31 where
28− 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
39+
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
29
48
30−hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
49+gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
31−hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
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 ++ "."
32
53
33jsonPrefix :: String -> Options
54jsonPrefix :: String -> Options
34jsonPrefix prefix = defaultOptions
55jsonPrefix prefix = defaultOptions
@@ -43,15 +64,6 @@ jsonPrefix prefix = defaultOptions
43 lowerFirstUppers s = map toLower x ++ y
64 lowerFirstUppers s = map toLower x ++ y
44 where (x, y) = span isUpper s
65 where (x, y) = span isUpper s
45
66
46−deriveToJSON' :: Name -> Q [Dec]
47−deriveToJSON' name = deriveToJSON (jsonPrefix (nameBase name)) name
48−
49−deriveJSONDefault :: Name -> Q [Dec]
50−deriveJSONDefault = deriveJSON (jsonPrefix "")
51−
52−deriveJSON' :: Name -> Q [Dec]
53−deriveJSON' name = deriveJSON (jsonPrefix (nameBase name)) name
54−
55parseOneOf :: ToJSON a => [a] -> Value -> Parser a
67parseOneOf :: ToJSON a => [a] -> Value -> Parser a
56parseOneOf xs js =
68parseOneOf xs js =
57 case lookup js ys of
69 case lookup js ys of
@@ -60,28 +72,10 @@ parseOneOf xs js =
60 where
72 where
61 ys = zip (map toJSON xs) xs
73 ys = zip (map toJSON xs) xs
62
74
63−genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
64−genericToJSONWithSub sub opts x =
65− case genericToJSON opts x of
66− Object o ->
67− let so = HashMap.lookupDefault (error "impossible") sub o
68− in Object (HashMap.delete sub o) <+> so
69− _ -> error "genericToJSONWithSub: subjson is not an object"
70−
71−genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
72−genericParseJSONWithSub sub opts (Object o) = genericParseJSON opts js
73− where
74− js = Object (HashMap.insert sub (Object o) o)
75−genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
76−
77(<+>) :: Value -> Value -> Value
75(<+>) :: Value -> Value -> Value
78Object x <+> Object y = Object (x <> y)
76Object x <+> Object y = Object (x <> y)
79_ <+> _ = error "<+>: merging non-objects"
77_ <+> _ = error "<+>: merging non-objects"
80
78
81−withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
82−withDefaults parser defs js@(Object _) = parser (js <+> object defs)
83−withDefaults _ _ _ = empty
84−
85genericMempty :: (Generic a, GMonoid (Rep a)) => a
79genericMempty :: (Generic a, GMonoid (Rep a)) => a
86genericMempty = to gmempty
80genericMempty = to gmempty
87
81
@@ -117,6 +111,16 @@ class SwaggerMonoid m where
117 swaggerMappend = mappend
111 swaggerMappend = mappend
118
112
119instance SwaggerMonoid [a]
113instance 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)
120
124
121instance SwaggerMonoid Text where
125instance SwaggerMonoid Text where
122 swaggerMempty = mempty
126 swaggerMempty = mempty
@@ -127,4 +131,3 @@ instance SwaggerMonoid (Maybe a) where
127 swaggerMempty = Nothing
131 swaggerMempty = Nothing
128 swaggerMappend x Nothing = x
132 swaggerMappend x Nothing = x
129 swaggerMappend _ y = y
133 swaggerMappend _ y = y
130−
src/Data/Swagger/Lens.hs+172−102
@@ -1,116 +1,186 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GADTs #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE TemplateHaskell #-}
8{-# 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.
5module Data.Swagger.Lens where
20module Data.Swagger.Lens where
6
21
7import Control.Lens
22import Control.Lens
8import Data.Aeson (Value)
23import Data.Aeson (Value)
9import Data.Scientific (Scientific)
24import Data.Scientific (Scientific)
10import Data.Swagger.Internal
25import Data.Swagger.Internal
26+import Data.Swagger.Internal.Utils
11import Data.Text (Text)
27import Data.Text (Text)
12
28
13−-- =======================================================================
14−-- TH derived lenses
29+-- * Classy lenses
15−-- =======================================================================
30+
16−
17−makeLenses ''Swagger
31+makeFields ''Swagger
18−makeLenses ''Host
32+makeFields ''Host
19−makeLenses ''Info
33+makeFields ''Info
20−makeLenses ''Contact
34+makeFields ''Contact
21−makeLenses ''License
35+makeFields ''License
22−makeLenses ''Paths
36+makeLensesWith swaggerFieldRules ''PathItem
23−makeLenses ''PathItem
37+makeFields ''Tag
24−makeLenses ''Tag
25−makeLenses ''Operation
38+makeFields ''Operation
26−makeLenses ''Param
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
27makePrisms ''ParamAnySchema
55makePrisms ''ParamAnySchema
28−makeLenses ''ParamOtherSchema
56+-- ** 'SecuritySchemeType' prisms
29−makeLenses ''Items
30−makeLenses ''Header
31−makeLenses ''Schema
32−makePrisms ''SchemaItems
33−makeLenses ''ParamSchema
34−makeLenses ''Xml
35−makeLenses ''Responses
36−makeLenses ''Response
37−makeLenses ''SecurityScheme
38makePrisms ''SecuritySchemeType
57makePrisms ''SecuritySchemeType
39−makeLenses ''ApiKeyParams
58+-- ** 'Referenced' prisms
40−makeLenses ''OAuth2Params
59+makePrisms ''Referenced
41−makeLenses ''ExternalDocs
60+
42−
61+-- ** 'SwaggerItems' prisms
43−-- =======================================================================
62+
44−-- Helper classy lenses
63+_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]
45−-- =======================================================================
64+_SwaggerItemsArray
46−
65+ = unto (\x -> SwaggerItemsArray x)
47−class HasDescription s d | s -> d where
66+{- \x -> case x of
48− description :: Lens' s d
67+ SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
49−
68+ SwaggerItemsObject o -> Left (SwaggerItemsObject o)
50−instance HasDescription Response Text where description = responseDescription
69+ SwaggerItemsArray a -> Right a
51−instance HasDescription Info (Maybe Text) where description = infoDescription
70+-}
52−instance HasDescription Tag (Maybe Text) where description = tagDescription
71+
53−instance HasDescription Operation (Maybe Text) where description = operationDescription
72+_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)
54−instance HasDescription Param (Maybe Text) where description = paramDescription
73+_SwaggerItemsObject
55−instance HasDescription Header (Maybe Text) where description = headerDescription
74+ = unto (\x -> SwaggerItemsObject x)
56−instance HasDescription Schema (Maybe Text) where description = schemaDescription
75+{- \x -> case x of
57−instance HasDescription SecurityScheme (Maybe Text) where description = securitySchemeDescription
76+ SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
58−instance HasDescription ExternalDocs (Maybe Text) where description = externalDocsDescription
77+ SwaggerItemsObject o -> Right o
59−
78+ SwaggerItemsArray a -> Left (SwaggerItemsArray a)
60−class HasParamSchema s t i | s -> t i where
79+-}
61− parameterSchema :: Lens' s (ParamSchema t i)
80+
62−
81+_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
63−instance HasParamSchema Schema Schema SchemaItems where parameterSchema = schemaParamSchema
82+_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
64−instance HasParamSchema ParamOtherSchema ParamOtherSchema Items where parameterSchema = paramOtherSchemaParamSchema
83+
65−instance HasParamSchema Items Items Items where parameterSchema = itemsParamSchema
84+-- =============================================================
66−instance HasParamSchema Header Header Items where parameterSchema = headerParamSchema
85+-- More helpful instances for easier access to schema properties
67−instance HasParamSchema (ParamSchema t i) t i where parameterSchema = id
86+
68−
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
69−schemaType :: HasParamSchema s t i => Lens' s (SwaggerType t)
124+ HasParamSchema s (ParamSchema t)
70−schemaType = parameterSchema.paramSchemaType
125+ => HasFormat s (Maybe Format) where
71−
126+ format = paramSchema.format
72−schemaFormat :: HasParamSchema s t i => Lens' s (Maybe Format)
127+
73−schemaFormat = parameterSchema.paramSchemaFormat
128+instance
74−
129+#if __GLASGOW_HASKELL__ >= 710
75−schemaItems :: HasParamSchema s t i => Lens' s (Maybe i)
130+ OVERLAPPABLE_
76−schemaItems = parameterSchema.paramSchemaItems
131+#endif
77−
78−schemaDefault :: HasParamSchema s t i => Lens' s (Maybe Value)
132+ HasParamSchema s (ParamSchema t)
79−schemaDefault = parameterSchema.paramSchemaDefault
133+ => HasItems s (Maybe (SwaggerItems t)) where
80−
134+ items = paramSchema.items
135+
136+instance
137+#if __GLASGOW_HASKELL__ >= 710
138+ OVERLAPPABLE_
139+#endif
81−schemaMaximum :: HasParamSchema s t i => Lens' s (Maybe Scientific)
140+ HasParamSchema s (ParamSchema t)
82−schemaMaximum = parameterSchema.paramSchemaMaximum
141+ => HasMaximum s (Maybe Scientific) where
83−
142+ maximum_ = paramSchema.maximum_
84−schemaExclusiveMaximum :: HasParamSchema s t i => Lens' s (Maybe Bool)
143+
85−schemaExclusiveMaximum = parameterSchema.paramSchemaExclusiveMaximum
144+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
86−
145+ => HasExclusiveMaximum s (Maybe Bool) where
87−schemaMinimum :: HasParamSchema s t i => Lens' s (Maybe Scientific)
146+ exclusiveMaximum = paramSchema.exclusiveMaximum
88−schemaMinimum = parameterSchema.paramSchemaMinimum
147+
89−
148+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
90−schemaExclusiveMinimum :: HasParamSchema s t i => Lens' s (Maybe Bool)
149+ => HasMinimum s (Maybe Scientific) where
91−schemaExclusiveMinimum = parameterSchema.paramSchemaExclusiveMinimum
150+ minimum_ = paramSchema.minimum_
92−
151+
93−schemaMaxLength :: HasParamSchema s t i => Lens' s (Maybe Integer)
152+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
94−schemaMaxLength = parameterSchema.paramSchemaMaxLength
153+ => HasExclusiveMinimum s (Maybe Bool) where
95−
154+ exclusiveMinimum = paramSchema.exclusiveMinimum
96−schemaMinLength :: HasParamSchema s t i => Lens' s (Maybe Integer)
155+
97−schemaMinLength = parameterSchema.paramSchemaMinLength
156+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
98−
157+ => HasMaxLength s (Maybe Integer) where
99−schemaPattern :: HasParamSchema s t i => Lens' s (Maybe Text)
158+ maxLength = paramSchema.maxLength
100−schemaPattern = parameterSchema.paramSchemaPattern
159+
101−
160+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
102−schemaMaxItems :: HasParamSchema s t i => Lens' s (Maybe Integer)
161+ => HasMinLength s (Maybe Integer) where
103−schemaMaxItems = parameterSchema.paramSchemaMaxItems
162+ minLength = paramSchema.minLength
104−
163+
105−schemaMinItems :: HasParamSchema s t i => Lens' s (Maybe Integer)
164+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
106−schemaMinItems = parameterSchema.paramSchemaMinItems
165+ => HasPattern s (Maybe Text) where
107−
166+ pattern = paramSchema.pattern
108−schemaUniqueItems :: HasParamSchema s t i => Lens' s (Maybe Bool)
167+
109−schemaUniqueItems = parameterSchema.paramSchemaUniqueItems
168+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
110−
169+ => HasMaxItems s (Maybe Integer) where
111−schemaEnum :: HasParamSchema s t i => Lens' s (Maybe [Value])
170+ maxItems = paramSchema.maxItems
112−schemaEnum = parameterSchema.paramSchemaEnum
171+
113−
172+instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
114−schemaMultipleOf :: HasParamSchema s t i => Lens' s (Maybe Scientific)
173+ => HasMinItems s (Maybe Integer) where
115−schemaMultipleOf = parameterSchema.paramSchemaMultipleOf
174+ minItems = paramSchema.minItems
116−
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.hs+5−2
@@ -1,7 +1,5 @@
1-- |
1-- |
2-- Module: Data.Swagger.ParamSchema
2-- Module: Data.Swagger.ParamSchema
3−-- Copyright: (c) 2015 GetShopTV
4−-- License: BSD3
5-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
6-- Stability: experimental
4-- Stability: experimental
7--
5--
@@ -14,6 +12,11 @@ module Data.Swagger.ParamSchema (
14 genericToParamSchema,
12 genericToParamSchema,
15 toParamSchemaBoundedIntegral,
13 toParamSchemaBoundedIntegral,
16
14
15+ -- * Schema templates
16+ passwordParamSchema,
17+ binaryParamSchema,
18+ byteParamSchema,
19+
17 -- * Generic encoding configuration
20 -- * Generic encoding configuration
18 SchemaOptions(..),
21 SchemaOptions(..),
19 defaultSchemaOptions,
22 defaultSchemaOptions,
src/Data/Swagger/Schema.hs+35−6
@@ -1,7 +1,5 @@
1-- |
1-- |
2-- Module: Data.Swagger.Schema
2-- Module: Data.Swagger.Schema
3−-- Copyright: (c) 2015 GetShopTV
4−-- License: BSD3
5-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
6-- Stability: experimental
4-- Stability: experimental
7--
5--
@@ -9,23 +7,54 @@
9module Data.Swagger.Schema (
7module Data.Swagger.Schema (
10 -- * Encoding
8 -- * Encoding
11 ToSchema(..),
9 ToSchema(..),
12− NamedSchema,
10+ declareSchema,
11+ declareSchemaRef,
13 toSchema,
12 toSchema,
14 toSchemaRef,
13 toSchemaRef,
15 schemaName,
14 schemaName,
15+ toInlinedSchema,
16
16
17 -- * Generic schema encoding
17 -- * Generic schema encoding
18− genericToSchema,
18+ genericDeclareNamedSchema,
19− genericToNamedSchema,
19+ genericDeclareSchema,
20− genericToSchemaDefinitions,
20+ genericDeclareNamedSchemaNewtype,
21+ genericNameSchema,
22+
23+ -- ** 'Bounded' 'Integral'
21 genericToNamedSchemaBoundedIntegral,
24 genericToNamedSchemaBoundedIntegral,
22 toSchemaBoundedIntegral,
25 toSchemaBoundedIntegral,
26+
27+ -- ** 'Bounded' 'Enum' key mappings
28+ declareSchemaBoundedEnumKeyMapping,
29+ toSchemaBoundedEnumKeyMapping,
30+
31+ -- ** Reusing 'ToParamSchema'
23 paramSchemaToNamedSchema,
32 paramSchemaToNamedSchema,
24 paramSchemaToSchema,
33 paramSchemaToSchema,
25
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+
26 -- * Generic encoding configuration
54 -- * Generic encoding configuration
27 SchemaOptions(..),
55 SchemaOptions(..),
28 defaultSchemaOptions,
56 defaultSchemaOptions,
57+ fromAesonOptions,
29) where
58) where
30
59
31import Data.Swagger.Internal.Schema
60import Data.Swagger.Internal.Schema
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/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.hs+35−18
@@ -1,5 +1,14 @@
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'@.
1module Data.Swagger.SchemaOptions where
8module Data.Swagger.SchemaOptions where
2
9
10+import qualified Data.Aeson.Types as Aeson
11+
3-- | Options that specify how to encode your type to Swagger schema.
12-- | Options that specify how to encode your type to Swagger schema.
4data SchemaOptions = SchemaOptions
13data SchemaOptions = SchemaOptions
5 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
14 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
@@ -11,22 +20,6 @@ data SchemaOptions = SchemaOptions
11 -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
20 -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
12 -- will be encoded to a string enumeration schema with the constructor tags as possible values.
21 -- will be encoded to a string enumeration schema with the constructor tags as possible values.
13 , allNullaryToStringTag :: Bool
22 , allNullaryToStringTag :: Bool
14− -- | If @'True'@ direct subschemas will be referenced if possible (rather than inlined).
15− -- Note that this option does not influence nested schemas, e.g. for these types
16− --
17− -- @
18− -- data Object = Object String deriving Generic
19− -- instance ToSchema Object
20− --
21− -- newtype Objects = Objects [Object] deriving Generic
22− -- instance ToSchema Objects where
23− -- toNamedSchema = genericToNamedSchema defaultSchemaOptions
24− -- { useReferences = False }
25− -- @
26− --
27− -- Schema for @Objects@ __will not__ inline @Object@ schema because
28− -- it is nested in a @[]@ schema.
29− , useReferences :: Bool
30 -- | Hide the field name when a record constructor has only one field, like a newtype.
23 -- | Hide the field name when a record constructor has only one field, like a newtype.
31 , unwrapUnaryRecords :: Bool
24 , unwrapUnaryRecords :: Bool
32 }
25 }
@@ -39,7 +32,6 @@ data SchemaOptions = SchemaOptions
39-- , 'constructorTagModifier' = id
32-- , 'constructorTagModifier' = id
40-- , 'datatypeNameModifier' = id
33-- , 'datatypeNameModifier' = id
41-- , 'allNullaryToStringTag' = True
34-- , 'allNullaryToStringTag' = True
42−-- , 'useReferences' = True
43-- , 'unwrapUnaryRecords' = False
35-- , 'unwrapUnaryRecords' = False
44-- }
36-- }
45-- @
37-- @
@@ -49,7 +41,32 @@ defaultSchemaOptions = SchemaOptions
49 , constructorTagModifier = id
41 , constructorTagModifier = id
50 , datatypeNameModifier = id
42 , datatypeNameModifier = id
51 , allNullaryToStringTag = True
43 , allNullaryToStringTag = True
52− , useReferences = True
53 , unwrapUnaryRecords = False
44 , unwrapUnaryRecords = False
54 }
45 }
55
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.yaml+6−2
@@ -1,5 +1,9 @@
1−flags: {}
1+resolver: lts-14.3
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-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+108−34
@@ -1,78 +1,152 @@
1+cabal-version: >=1.10
1name: swagger2
2name: swagger2
2−version: 0.4.1
3+version: 2.5
4+
3synopsis: Swagger 2.0 data model
5synopsis: Swagger 2.0 data model
6+category: Web, Swagger
4−description: Please see README.md
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+
5homepage: https://github.com/GetShopTV/swagger2
13homepage: https://github.com/GetShopTV/swagger2
6bug-reports: https://github.com/GetShopTV/swagger2/issues
14bug-reports: https://github.com/GetShopTV/swagger2/issues
7license: BSD3
15license: BSD3
8license-file: LICENSE
16license-file: LICENSE
9author: Nickolay Kudasov
17author: Nickolay Kudasov
10maintainer: nickolay@getshoptv.com
18maintainer: nickolay@getshoptv.com
11−copyright: (c) 2015, GetShopTV
19+copyright: (c) 2015-2016, GetShopTV
12−category: Web
13−build-type: Simple
20+build-type: Custom
14extra-source-files:
21extra-source-files:
15 README.md
22 README.md
16 , CHANGELOG.md
23 , 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
18
36
19library
37library
20 hs-source-dirs: src
38 hs-source-dirs: src
39+ include-dirs: include
21 exposed-modules:
40 exposed-modules:
22 Data.Swagger
41 Data.Swagger
23 Data.Swagger.Declare
42 Data.Swagger.Declare
24 Data.Swagger.Lens
43 Data.Swagger.Lens
44+ Data.Swagger.Operation
45+ Data.Swagger.Optics
25 Data.Swagger.ParamSchema
46 Data.Swagger.ParamSchema
26 Data.Swagger.Schema
47 Data.Swagger.Schema
48+ Data.Swagger.Schema.Generator
49+ Data.Swagger.Schema.Validation
27 Data.Swagger.SchemaOptions
50 Data.Swagger.SchemaOptions
28
51
29 -- internal modules
52 -- internal modules
30 Data.Swagger.Internal
53 Data.Swagger.Internal
31 Data.Swagger.Internal.Schema
54 Data.Swagger.Internal.Schema
55+ Data.Swagger.Internal.Schema.Validation
32 Data.Swagger.Internal.ParamSchema
56 Data.Swagger.Internal.ParamSchema
33 Data.Swagger.Internal.Utils
57 Data.Swagger.Internal.Utils
58+ Data.Swagger.Internal.AesonUtils
59+ Data.Swagger.Internal.TypeShape
60+
61+ -- GHC boot libraries
34− build-depends: base == 4.*
62+ build-depends:
63+ base >=4.9 && <4.14
35− , aeson < 0.10
64+ , aeson-pretty >=0.8.7 && <0.9
65+ , bytestring >=0.10.4.0 && <0.11
36− , containers
66+ , containers >=0.5.5.1 && <0.7
67+ , template-haskell >=2.9.0.0 && <2.16
68+ , time >=1.4.2 && <1.10
69+ , transformers >=0.3.0.0 && <0.6
70+
71+ build-depends:
72+ mtl >=2.1 && <2.3
73+ , text >=1.2.3.0 && <1.3
74+
75+ -- other dependencies
76+ build-depends:
77+ base-compat-batteries >=0.10.4 && <0.12
78+ , aeson >=1.4.2.0 && <1.5
79+ -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
80+ , cookie >=0.4.3 && <0.5
81+ , generics-sop >=0.3.2.0 && <0.6
37− , hashable
82+ , hashable >=1.2.7.0 && <1.4
38− , http-media
83+ , http-media >=0.7.1.2 && <0.9
39− , mtl
84+ , insert-ordered-containers >=0.2.3 && <0.3
85+ , lens >=4.16.1 && <4.19
40− , network
86+ , network >=2.6.3.5 && <3.2
41− , template-haskell
87+ , optics-core >=0.2 && <0.3
42− , text
88+ , optics-th >=0.2 && <0.3
43− , time
44− , unordered-containers
45− , lens
46− , scientific
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+
47 default-language: Haskell2010
96 default-language: Haskell2010
48
97
49test-suite spec
98test-suite spec
50 type: exitcode-stdio-1.0
99 type: exitcode-stdio-1.0
51 hs-source-dirs: test
100 hs-source-dirs: test
52 main-is: Spec.hs
101 main-is: Spec.hs
102+
103+ -- From library parat
104+ -- We need aeson's toEncoding for doctests too
53− build-depends: base == 4.*
105+ build-depends:
106+ base
54− , swagger2
107+ , swagger2
55− , hspec
108+ , aeson
56− , HUnit
109+ , base-compat-batteries
57− , QuickCheck
110+ , bytestring
111+ , containers
112+ , hashable
113+ , insert-ordered-containers
114+ , lens
115+ , mtl
116+ , template-haskell
58− , text
117+ , text
59− , aeson
118+ , time
60− , aeson-qq
61− , containers
62− , unordered-containers
119+ , unordered-containers
63− , vector
120+ , vector
64− , lens
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+
65 other-modules:
134 other-modules:
66 SpecCommon
135 SpecCommon
67 Data.SwaggerSpec
136 Data.SwaggerSpec
137+ Data.Swagger.CommonTestTypes
138+ Data.Swagger.ParamSchemaSpec
68 Data.Swagger.SchemaSpec
139 Data.Swagger.SchemaSpec
140+ Data.Swagger.Schema.ValidationSpec
141+ Data.Swagger.Schema.GeneratorSpec
69 default-language: Haskell2010
142 default-language: Haskell2010
70
143
71−test-suite doctest
144+test-suite doctests
145+ -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
72− build-depends: base, doctest, Glob
146+ build-depends: base, doctest, Glob, QuickCheck
73 default-language: Haskell2010
147 default-language: Haskell2010
74 hs-source-dirs: test
148 hs-source-dirs: test
75− main-is: DocTest.hs
149+ main-is: doctests.hs
76 type: exitcode-stdio-1.0
150 type: exitcode-stdio-1.0
77
151
78source-repository head
152source-repository head
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.hs+11−68
@@ -1,97 +1,40 @@
1{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
2+{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE QuasiQuotes #-}
5{-# LANGUAGE QuasiQuotes #-}
6+{-# LANGUAGE OverloadedStrings #-}
6module Data.Swagger.ParamSchemaSpec where
7module Data.Swagger.ParamSchemaSpec where
7
8
8import Data.Aeson
9import Data.Aeson
9−import Data.Aeson.QQ
10+import Data.Aeson.QQ.Simple
10import Data.Char
11import Data.Char
11import Data.Proxy
12import Data.Proxy
12−import Data.Set (Set)
13import GHC.Generics
13import GHC.Generics
14
14
15import Data.Swagger
15import Data.Swagger
16+import Data.Swagger.Internal (SwaggerKind(..))
16
17
18+import Data.Swagger.CommonTestTypes
17import SpecCommon
19import SpecCommon
18import Test.Hspec
20import Test.Hspec
21+import Data.Time.LocalTime
22+
23+import qualified Data.HashMap.Strict as HM
19
24
20checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
25checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
21−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param Items) <=> js
26+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
22
27
23spec :: Spec
28spec :: Spec
24spec = do
29spec = do
25 describe "Generic ToParamSchema" $ do
30 describe "Generic ToParamSchema" $ do
31+ context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
26 context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
32 context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
27 context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
33 context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
28 context "Unary records" $ do
34 context "Unary records" $ do
29 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
35 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
30 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
36 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
31
38
32main :: IO ()
39main :: IO ()
33main = hspec spec
40main = hspec spec
34−
35−-- ========================================================================
36−-- Color (enum)
37−-- ========================================================================
38−data Color
39− = Red
40− | Green
41− | Blue
42− deriving (Generic, ToParamSchema)
43−
44−colorSchemaJSON :: Value
45−colorSchemaJSON = [aesonQQ|
46−{
47− "type": "string",
48− "enum": ["Red", "Green", "Blue"]
49−}
50−|]
51−
52−-- ========================================================================
53−-- Status (constructorTagModifier)
54−-- ========================================================================
55−
56−data Status = StatusOk | StatusError deriving (Generic)
57−
58−instance ToParamSchema Status where
59− toParamSchema = genericToParamSchema defaultSchemaOptions
60− { constructorTagModifier = map toLower . drop (length "Status") }
61−
62−statusSchemaJSON :: Value
63−statusSchemaJSON = [aesonQQ|
64−{
65− "type": "string",
66− "enum": ["ok", "error"]
67−}
68−|]
69−
70−-- ========================================================================
71−-- Email (newtype with unwrapUnaryRecords set to True)
72−-- ========================================================================
73−
74−newtype Email = Email { getEmail :: String }
75− deriving (Generic, ToParamSchema)
76−
77−emailSchemaJSON :: Value
78−emailSchemaJSON = [aesonQQ|
79−{
80− "type": "string"
81−}
82−|]
83−
84−-- ========================================================================
85−-- UserId (non-record newtype)
86−-- ========================================================================
87−
88−newtype UserId = UserId Integer
89− deriving (Generic, ToParamSchema)
90−
91−userIdSchemaJSON :: Value
92−userIdSchemaJSON = [aesonQQ|
93−{
94− "type": "integer"
95−}
96−|]
97−
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+51−375
@@ -1,41 +1,63 @@
1{-# LANGUAGE DeriveGeneric #-}
1{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
3{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE QuasiQuotes #-}
4{-# LANGUAGE QuasiQuotes #-}
6module Data.Swagger.SchemaSpec where
5module Data.Swagger.SchemaSpec where
7
6
8−import Data.Aeson
7+import Prelude ()
9−import Data.Aeson.QQ
8+import Prelude.Compat
9+
10+import Control.Lens ((^.))
10−import Data.Char
11+import Data.Aeson (Value)
11−import qualified Data.HashMap.Strict as HashMap
12+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
12import Data.Proxy
13import Data.Proxy
13import Data.Set (Set)
14import Data.Set (Set)
14−import qualified Data.Set as Set
15−import Data.Text (Text)
16import qualified Data.Text as Text
15import qualified Data.Text as Text
17−import GHC.Generics
18
16
19import Data.Swagger
17import Data.Swagger
20import Data.Swagger.Declare
18import Data.Swagger.Declare
21
19
20+import Data.Swagger.CommonTestTypes
22import SpecCommon
21import SpecCommon
23import Test.Hspec
22import Test.Hspec
24
23
24+import qualified Data.HashMap.Strict as HM
25+import Data.Time.LocalTime
26+
25checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
27checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
26−checkToSchema proxy js = toSchema proxy <~> js
28+checkToSchema proxy js = toSchema proxy <=> js
27
29
28checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
30checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
29checkSchemaName sname proxy =
31checkSchemaName sname proxy =
30 it ("schema name is " ++ show sname) $
32 it ("schema name is " ++ show sname) $
31− schemaName proxy `shouldBe` sname
33+ schemaName proxy `shouldBe` fmap Text.pack sname
32
34
33checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
35checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
34checkDefs proxy names =
36checkDefs proxy names =
35 it ("uses these definitions " ++ show names) $
37 it ("uses these definitions " ++ show names) $
36− Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack 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
37 where
59 where
38− defs = execDeclare (toSchemaDefinitions proxy) mempty
60+ (defs, s) = runDeclare (declareSchema proxy) mempty
39
61
40spec :: Spec
62spec :: Spec
41spec = do
63spec = do
@@ -44,6 +66,9 @@ spec = do
44 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
66 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
45 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
67 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
46 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON
68 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
47 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
72 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
48 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
73 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
49 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
74 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
@@ -52,8 +77,10 @@ spec = do
52 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
77 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
53 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
78 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
54 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
79 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80+ context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
55 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
81 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
56 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
82 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
57 context "Sum types" $ do
84 context "Sum types" $ do
58 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
85 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
59 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
86 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -69,370 +96,19 @@ spec = do
69 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
96 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
70 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
97 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
71 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
98 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99+ context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
72 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
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
73
112
74main :: IO ()
113main :: IO ()
75main = hspec spec
114main = hspec spec
76−
77−-- ========================================================================
78−-- Person (simple record with optional fields)
79−-- ========================================================================
80−data Person = Person
81− { name :: String
82− , phone :: Integer
83− , email :: Maybe String
84− } deriving (Generic, ToSchema)
85−
86−personSchemaJSON :: Value
87−personSchemaJSON = [aesonQQ|
88−{
89− "type": "object",
90− "properties":
91− {
92− "name": { "type": "string" },
93− "phone": { "type": "integer" },
94− "email": { "type": "string" }
95− },
96− "required": ["name", "phone"]
97−}
98−|]
99−
100−-- ========================================================================
101−-- ISPair (non-record product data type)
102−-- ========================================================================
103−data ISPair = ISPair Integer String
104− deriving (Generic, ToSchema)
105−
106−ispairSchemaJSON :: Value
107−ispairSchemaJSON = [aesonQQ|
108−{
109− "type": "array",
110− "items":
111− [
112− { "type": "integer" },
113− { "type": "string" }
114− ]
115−}
116−|]
117−
118−-- ========================================================================
119−-- Point (record data type with custom fieldLabelModifier)
120−-- ========================================================================
121−data Point = Point
122− { pointX :: Double
123− , pointY :: Double
124− } deriving (Generic)
125−
126−instance ToSchema Point where
127− toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
128− { fieldLabelModifier = map toLower . drop (length "point") }
129−
130−pointSchemaJSON :: Value
131−pointSchemaJSON = [aesonQQ|
132−{
133− "type": "object",
134− "properties":
135− {
136− "x": { "type": "number" },
137− "y": { "type": "number" }
138− },
139− "required": ["x", "y"]
140−}
141−|]
142−
143−
144−-- ========================================================================
145−-- Color (enum)
146−-- ========================================================================
147−data Color
148− = Red
149− | Green
150− | Blue
151− deriving (Generic, ToSchema)
152−
153−colorSchemaJSON :: Value
154−colorSchemaJSON = [aesonQQ|
155−{
156− "type": "string",
157− "enum": ["Red", "Green", "Blue"]
158−}
159−|]
160−
161−-- ========================================================================
162−-- Shade (paramSchemaToNamedSchema)
163−-- ========================================================================
164−
165−data Shade = Dim | Bright deriving (Generic, ToParamSchema)
166−
167−instance ToSchema Shade where toSchemaDefinitions = pure . paramSchemaToNamedSchema defaultSchemaOptions
168−
169−shadeSchemaJSON :: Value
170−shadeSchemaJSON = [aesonQQ|
171−{
172− "type": "string",
173− "enum": ["Dim", "Bright"]
174−}
175−|]
176−
177−-- ========================================================================
178−-- Paint (record with bounded enum property)
179−-- ========================================================================
180−
181−newtype Paint = Paint { color :: Color }
182− deriving (Generic, ToSchema)
183−
184−paintSchemaJSON :: Value
185−paintSchemaJSON = [aesonQQ|
186−{
187− "type": "object",
188− "properties":
189− {
190− "color":
191− {
192− "$ref": "#/definitions/Color"
193− }
194− },
195− "required": ["color"]
196−}
197−|]
198−
199−-- ========================================================================
200−-- Email (newtype with unwrapUnaryRecords set to True)
201−-- ========================================================================
202−
203−newtype Email = Email { getEmail :: String }
204− deriving (Generic)
205−
206−instance ToSchema Email where
207− toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
208− { unwrapUnaryRecords = True }
209−
210−emailSchemaJSON :: Value
211−emailSchemaJSON = [aesonQQ|
212−{
213− "type": "string"
214−}
215−|]
216−
217−-- ========================================================================
218−-- UserId (non-record newtype)
219−-- ========================================================================
220−
221−newtype UserId = UserId Integer
222− deriving (Eq, Ord, Generic, ToSchema)
223−
224−userIdSchemaJSON :: Value
225−userIdSchemaJSON = [aesonQQ|
226−{
227− "type": "integer"
228−}
229−|]
230−
231−-- ========================================================================
232−-- UserGroup (set newtype)
233−-- ========================================================================
234−
235−newtype UserGroup = UserGroup (Set UserId)
236− deriving (Generic, ToSchema)
237−
238−userGroupSchemaJSON :: Value
239−userGroupSchemaJSON = [aesonQQ|
240−{
241− "type": "array",
242− "items": { "$ref": "#/definitions/UserId" },
243− "uniqueItems": true
244−}
245−|]
246−
247−-- ========================================================================
248−-- Player (record newtype)
249−-- ========================================================================
250−
251−newtype Player = Player
252− { position :: Point
253− } deriving (Generic, ToSchema)
254−
255−playerSchemaJSON :: Value
256−playerSchemaJSON = [aesonQQ|
257−{
258− "type": "object",
259− "properties":
260− {
261− "position":
262− {
263− "$ref": "#/definitions/Point"
264− }
265− },
266− "required": ["position"]
267−}
268−|]
269−
270−-- ========================================================================
271−-- MyRoseTree (custom datatypeNameModifier)
272−-- ========================================================================
273−
274−data MyRoseTree = MyRoseTree
275− { root :: String
276− , trees :: [MyRoseTree]
277− } deriving (Generic)
278−
279−instance ToSchema MyRoseTree where
280− toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
281− { datatypeNameModifier = drop (length "My") }
282−
283−myRoseTreeSchemaJSON :: Value
284−myRoseTreeSchemaJSON = [aesonQQ|
285−{
286− "type": "object",
287− "properties":
288− {
289− "root": { "type": "string" },
290− "trees":
291− {
292− "type": "array",
293− "items":
294− {
295− "$ref": "#/definitions/RoseTree"
296− }
297− }
298− },
299− "required": ["root", "trees"]
300−}
301−|]
302−
303−-- ========================================================================
304−-- Inlined (newtype for inlining schemas)
305−-- ========================================================================
306−
307−newtype Inlined a = Inlined { getInlined :: a }
308−
309−instance ToSchema a => ToSchema (Inlined a) where
310− toSchemaDefinitions _ = unname <$> toSchemaDefinitions (Proxy :: Proxy a)
311− where
312− unname (_, schema) = (Nothing, schema)
313−
314−newtype Players = Players [Inlined Player]
315− deriving (Generic, ToSchema)
316−
317−playersSchemaJSON :: Value
318−playersSchemaJSON = [aesonQQ|
319−{
320− "type": "array",
321− "items":
322− {
323− "type": "object",
324− "properties":
325− {
326− "position":
327− {
328− "$ref": "#/definitions/Point"
329− }
330− },
331− "required": ["position"]
332− }
333−}
334−|]
335−
336−-- ========================================================================
337−-- Status (sum type with unary constructors)
338−-- ========================================================================
339−
340−data Status
341− = StatusOk String
342− | StatusError String
343− deriving (Generic)
344−
345−instance ToSchema Status where
346− toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
347− { constructorTagModifier = map toLower . drop (length "Status") }
348−
349−statusSchemaJSON :: Value
350−statusSchemaJSON = [aesonQQ|
351−{
352− "type": "object",
353− "properties":
354− {
355− "ok": { "type": "string" },
356− "error": { "type": "string" }
357− },
358− "maxProperties": 1,
359− "minProperties": 1
360−}
361−|]
362−
363−-- ========================================================================
364−-- Unit type
365−-- ========================================================================
366−
367−data Unit = Unit deriving (Generic, ToSchema)
368−
369−unitSchemaJSON :: Value
370−unitSchemaJSON = [aesonQQ|
371−{
372− "type": "array",
373− "enum": [[]]
374−}
375−|]
376−
377−
378−-- ========================================================================
379−-- Character (sum type with ref and record in alternative)
380−-- ========================================================================
381−
382−data Character
383− = PC Player
384− | NPC { npcName :: String, npcPosition :: Point }
385− deriving (Generic, ToSchema)
386−
387−characterSchemaJSON :: Value
388−characterSchemaJSON = [aesonQQ|
389−{
390− "type": "object",
391− "properties":
392− {
393− "PC": { "$ref": "#/definitions/Player" },
394− "NPC":
395− {
396− "type": "object",
397− "properties":
398− {
399− "npcName": { "type": "string" },
400− "npcPosition": { "$ref": "#/definitions/Point" }
401− },
402− "required": ["npcName", "npcPosition"]
403− }
404− },
405− "maxProperties": 1,
406− "minProperties": 1
407−}
408−|]
409−
410−-- ========================================================================
411−-- Light (sum type with unwrapUnaryRecords)
412−-- ========================================================================
413−
414−data Light
415− = LightFreq Double
416− | LightColor Color
417− | LightWaveLength { waveLength :: Double }
418− deriving (Generic)
419−
420−instance ToSchema Light where
421− toSchemaDefinitions = genericToSchemaDefinitions defaultSchemaOptions
422− { unwrapUnaryRecords = True }
423−
424−lightSchemaJSON :: Value
425−lightSchemaJSON = [aesonQQ|
426−{
427− "type": "object",
428− "properties":
429− {
430− "LightFreq": { "type": "number" },
431− "LightColor": { "$ref": "#/definitions/Color" },
432− "LightWaveLength": { "type": "number" }
433− },
434− "maxProperties": 1,
435− "minProperties": 1
436−}
437−|]
438−
test/Data/SwaggerSpec.hs+541−460
@@ -4,35 +4,49 @@
4{-# LANGUAGE QuasiQuotes #-}
4{-# LANGUAGE QuasiQuotes #-}
5module Data.SwaggerSpec where
5module Data.SwaggerSpec where
6
6
7+import Prelude ()
8+import Prelude.Compat
9+
7import Control.Lens
10import Control.Lens
8
11
9import Data.Aeson
12import Data.Aeson
10−import Data.Aeson.QQ
13+import Data.Aeson.QQ.Simple
11import Data.HashMap.Strict (HashMap)
14import Data.HashMap.Strict (HashMap)
15+import qualified Data.HashSet.InsOrd as InsOrdHS
12import Data.Text (Text)
16import Data.Text (Text)
13
17
14import Data.Swagger
18import Data.Swagger
15−import Data.Swagger.Lens
16import SpecCommon
19import SpecCommon
17−import Test.Hspec
20+import Test.Hspec hiding (example)
18
21
19spec :: Spec
22spec :: Spec
20spec = do
23spec = do
24+ describe "host" $ do
25+ it "can decode the host port" $ do
26+ let h = Just $ Host "localhost" (Just (fromInteger 8000))
27+ swagger :: Swagger
28+ swagger = swaggerExample
29+ & host .~ h
30+ parsed :: Swagger = either error id $ eitherDecode' $ encode swagger
31+ parsed ^. host `shouldBe` h
21 describe "License Object" $ licenseExample <=> licenseExampleJSON
32 describe "License Object" $ licenseExample <=> licenseExampleJSON
22 describe "Contact Object" $ contactExample <=> contactExampleJSON
33 describe "Contact Object" $ contactExample <=> contactExampleJSON
23 describe "Info Object" $ infoExample <=> infoExampleJSON
34 describe "Info Object" $ infoExample <=> infoExampleJSON
24− describe "Operation Object" $ operationExample <~> operationExampleJSON
35+ describe "Operation Object" $ operationExample <=> operationExampleJSON
25 describe "Schema Object" $ do
36 describe "Schema Object" $ do
26− context "Primitive Sample" $ schemaPrimitiveExample <~> schemaPrimitiveExampleJSON
37+ context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
27− context "Simple Model" $ schemaSimpleModelExample <~> schemaSimpleModelExampleJSON
38+ context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
28− context "Model with Map/Dictionary Properties" $ schemaModelDictExample <~> schemaModelDictExampleJSON
39+ context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
29− context "Model with Example" $ schemaWithExampleExample <~> schemaWithExampleExampleJSON
41+ context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
30− describe "Definitions Object" $ definitionsExample <~> definitionsExampleJSON
42+ describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
31− describe "Parameters Definition Object" $ paramsDefinitionExample <~> paramsDefinitionExampleJSON
43+ describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
32− describe "Responses Definition Object" $ responsesDefinitionExample <~> responsesDefinitionExampleJSON
44+ describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
33− describe "Security Definitions Object" $ securityDefinitionsExample <~> securityDefinitionsExampleJSON
45+ describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
47+ describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
34 describe "Swagger Object" $ do
48 describe "Swagger Object" $ do
35− context "Todo Example" $ swaggerExample <~> swaggerExampleJSON
49+ context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
36 context "PetStore Example" $
50 context "PetStore Example" $
37 it "decodes successfully" $ do
51 it "decodes successfully" $ do
38 fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False)
52 fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False)
@@ -45,13 +59,13 @@ main = hspec spec
45-- =======================================================================
59-- =======================================================================
46
60
47infoExample :: Info
61infoExample :: Info
48−infoExample = Info
62+infoExample = mempty
49− { _infoTitle = "Swagger Sample App"
63+ & title .~ "Swagger Sample App"
50− , _infoDescription = Just "This is a sample server Petstore server."
64+ & description ?~ "This is a sample server Petstore server."
51− , _infoTermsOfService = Just "http://swagger.io/terms/"
65+ & termsOfService ?~ "http://swagger.io/terms/"
52− , _infoContact = Just contactExample
66+ & contact ?~ contactExample
53− , _infoLicense = Just licenseExample
67+ & license ?~ licenseExample
54− , _infoVersion = "1.0.1" }
68+ & version .~ "1.0.1"
55
69
56infoExampleJSON :: Value
70infoExampleJSON :: Value
57infoExampleJSON = [aesonQQ|
71infoExampleJSON = [aesonQQ|
@@ -77,10 +91,10 @@ infoExampleJSON = [aesonQQ|
77-- =======================================================================
91-- =======================================================================
78
92
79contactExample :: Contact
93contactExample :: Contact
80−contactExample = Contact
94+contactExample = mempty
81− { _contactName = Just "API Support"
95+ & name ?~ "API Support"
82− , _contactUrl = Just (URL "http://www.swagger.io/support")
96+ & url ?~ URL "http://www.swagger.io/support"
83− , _contactEmail = Just "support@swagger.io" }
97+ & email ?~ "support@swagger.io"
84
98
85contactExampleJSON :: Value
99contactExampleJSON :: Value
86contactExampleJSON = [aesonQQ|
100contactExampleJSON = [aesonQQ|
@@ -96,9 +110,8 @@ contactExampleJSON = [aesonQQ|
96-- =======================================================================
110-- =======================================================================
97
111
98licenseExample :: License
112licenseExample :: License
99−licenseExample = License
113+licenseExample = "Apache 2.0"
100− { _licenseName = "Apache 2.0"
101− , _licenseUrl = Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html") }
114+ & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"
102
115
103licenseExampleJSON :: Value
116licenseExampleJSON :: Value
104licenseExampleJSON = [aesonQQ|
117licenseExampleJSON = [aesonQQ|
@@ -115,46 +128,38 @@ licenseExampleJSON = [aesonQQ|
115
128
116operationExample :: Operation
129operationExample :: Operation
117operationExample = mempty
130operationExample = mempty
118− { _operationTags = ["pet"]
131+ & tags .~ InsOrdHS.fromList ["pet"]
119− , _operationSummary = Just "Updates a pet in the store with form data"
132+ & summary ?~ "Updates a pet in the store with form data"
120− , _operationDescription = Just ""
133+ & description ?~ ""
121− , _operationOperationId = Just "updatePetWithForm"
134+ & operationId ?~ "updatePetWithForm"
122− , _operationConsumes = Just (MimeList ["application/x-www-form-urlencoded"])
135+ & consumes ?~ MimeList ["application/x-www-form-urlencoded"]
123− , _operationProduces = Just (MimeList ["application/json", "application/xml"])
136+ & produces ?~ MimeList ["application/json", "application/xml"]
124− , _operationParameters = params
125− , _operationResponses = responses
126− , _operationSecurity = security
127− }
128− where
129− security = [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
130−
131− responses = mempty
132− { _responsesResponses =
133− [ (200, Inline mempty { _responseDescription = "Pet updated." })
134− , (405, Inline mempty { _responseDescription = "Invalid input" }) ] }
135−
136− params = map Inline
137+ & parameters .~ map Inline
137− [ Param
138+ [ mempty
138− { _paramName = "petId"
139+ & name .~ "petId"
139− , _paramDescription = Just "ID of pet that needs to be updated"
140+ & description ?~ "ID of pet that needs to be updated"
140− , _paramRequired = Just True
141+ & required ?~ True
141− , _paramSchema = ParamOther (stringSchema ParamPath) }
142+ & schema .~ ParamOther (stringSchema ParamPath)
142− , Param
143+ , mempty
143− { _paramName = "name"
144+ & name .~ "name"
144− , _paramDescription = Just "Updated name of the pet"
145+ & description ?~ "Updated name of the pet"
145− , _paramRequired = Just False
146+ & required ?~ False
146− , _paramSchema = ParamOther (stringSchema ParamFormData) }
147+ & schema .~ ParamOther (stringSchema ParamFormData)
147− , Param
148+ , mempty
148− { _paramName = "status"
149+ & name .~ "status"
149− , _paramDescription = Just "Updated status of the pet"
150+ & description ?~ "Updated status of the pet"
150− , _paramRequired = Just False
151+ & required ?~ False
151− , _paramSchema = ParamOther (stringSchema ParamFormData) }
152+ & schema .~ ParamOther (stringSchema ParamFormData)
152 ]
153 ]
153
154
155+ & at 200 ?~ "Pet updated."
156+ & at 405 ?~ "Invalid input"
157+ & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
158+ where
154 stringSchema :: ParamLocation -> ParamOtherSchema
159 stringSchema :: ParamLocation -> ParamOtherSchema
155− stringSchema i = mempty
160+ stringSchema loc = mempty
156− & paramOtherSchemaIn .~ i
161+ & in_ .~ loc
157− & schemaType .~ SwaggerString
162+ & type_ ?~ SwaggerString
158
163
159operationExampleJSON :: Value
164operationExampleJSON :: Value
160operationExampleJSON = [aesonQQ|
165operationExampleJSON = [aesonQQ|
@@ -220,8 +225,8 @@ operationExampleJSON = [aesonQQ|
220
225
221schemaPrimitiveExample :: Schema
226schemaPrimitiveExample :: Schema
222schemaPrimitiveExample = mempty
227schemaPrimitiveExample = mempty
223− & schemaType .~ SwaggerString
228+ & type_ ?~ SwaggerString
224− & schemaFormat ?~ "email"
229+ & format ?~ "email"
225
230
226schemaPrimitiveExampleJSON :: Value
231schemaPrimitiveExampleJSON :: Value
227schemaPrimitiveExampleJSON = [aesonQQ|
232schemaPrimitiveExampleJSON = [aesonQQ|
@@ -233,15 +238,15 @@ schemaPrimitiveExampleJSON = [aesonQQ|
233
238
234schemaSimpleModelExample :: Schema
239schemaSimpleModelExample :: Schema
235schemaSimpleModelExample = mempty
240schemaSimpleModelExample = mempty
236− & schemaType .~ SwaggerObject
241+ & type_ ?~ SwaggerObject
237− & schemaRequired .~ [ "name" ]
242+ & required .~ [ "name" ]
238− & schemaProperties .~
243+ & properties .~
239− [ ("name", Inline (mempty & schemaType .~ SwaggerString))
244+ [ ("name", Inline (mempty & type_ ?~ SwaggerString))
240− , ("address", Ref (Reference "#/definitions/Address"))
245+ , ("address", Ref (Reference "Address"))
241 , ("age", Inline $ mempty
246 , ("age", Inline $ mempty
242− & schemaMinimum ?~ 0
247+ & minimum_ ?~ 0
243− & schemaType .~ SwaggerInteger
248+ & type_ ?~ SwaggerInteger
244− & schemaFormat ?~ "int32" ) ]
249+ & format ?~ "int32" ) ]
245
250
246schemaSimpleModelExampleJSON :: Value
251schemaSimpleModelExampleJSON :: Value
247schemaSimpleModelExampleJSON = [aesonQQ|
252schemaSimpleModelExampleJSON = [aesonQQ|
@@ -268,8 +273,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
268
273
269schemaModelDictExample :: Schema
274schemaModelDictExample :: Schema
270schemaModelDictExample = mempty
275schemaModelDictExample = mempty
271− & schemaType .~ SwaggerObject
276+ & type_ ?~ SwaggerObject
272− & schemaAdditionalProperties ?~ (mempty & schemaType .~ SwaggerString)
277+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
273
278
274schemaModelDictExampleJSON :: Value
279schemaModelDictExampleJSON :: Value
275schemaModelDictExampleJSON = [aesonQQ|
280schemaModelDictExampleJSON = [aesonQQ|
@@ -281,20 +286,35 @@ schemaModelDictExampleJSON = [aesonQQ|
281}
286}
282|]
287|]
283
288
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+
284schemaWithExampleExample :: Schema
302schemaWithExampleExample :: Schema
285−schemaWithExampleExample = (mempty & schemaType .~ SwaggerObject)
303+schemaWithExampleExample = mempty
286− { _schemaProperties =
304+ & type_ ?~ SwaggerObject
305+ & properties .~
287 [ ("id", Inline $ mempty
306 [ ("id", Inline $ mempty
288− & schemaType .~ SwaggerInteger
307+ & type_ ?~ SwaggerInteger
289− & schemaFormat ?~ "int64" )
308+ & format ?~ "int64" )
290− , ("name", Inline (mempty & schemaType .~ SwaggerString)) ]
309+ , ("name", Inline $ mempty
291− , _schemaRequired = [ "name" ]
310+ & type_ ?~ SwaggerString) ]
292− , _schemaExample = Just [aesonQQ|
311+ & required .~ [ "name" ]
312+ & example ?~ [aesonQQ|
293− {
313+ {
294− "name": "Puma",
314+ "name": "Puma",
295− "id": 1
315+ "id": 1
296− }
316+ }
297− |] }
317+ |]
298
318
299schemaWithExampleExampleJSON :: Value
319schemaWithExampleExampleJSON :: Value
300schemaWithExampleExampleJSON = [aesonQQ|
320schemaWithExampleExampleJSON = [aesonQQ|
@@ -326,19 +346,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
326definitionsExample :: HashMap Text Schema
346definitionsExample :: HashMap Text Schema
327definitionsExample =
347definitionsExample =
328 [ ("Category", mempty
348 [ ("Category", mempty
329− & schemaType .~ SwaggerObject
349+ & type_ ?~ SwaggerObject
330− & schemaProperties .~
350+ & properties .~
331 [ ("id", Inline $ mempty
351 [ ("id", Inline $ mempty
332− & schemaType .~ SwaggerInteger
352+ & type_ ?~ SwaggerInteger
333− & schemaFormat ?~ "int64")
353+ & format ?~ "int64")
334− , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] )
354+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
335 , ("Tag", mempty
355 , ("Tag", mempty
336− & schemaType .~ SwaggerObject
356+ & type_ ?~ SwaggerObject
337− & schemaProperties .~
357+ & properties .~
338 [ ("id", Inline $ mempty
358 [ ("id", Inline $ mempty
339− & schemaType .~ SwaggerInteger
359+ & type_ ?~ SwaggerInteger
340− & schemaFormat ?~ "int64")
360+ & format ?~ "int64")
341− , ("name", Inline (mempty & schemaType .~ SwaggerString)) ] ) ]
361+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
342
362
343definitionsExampleJSON :: Value
363definitionsExampleJSON :: Value
344definitionsExampleJSON = [aesonQQ|
364definitionsExampleJSON = [aesonQQ|
@@ -377,21 +397,21 @@ definitionsExampleJSON = [aesonQQ|
377paramsDefinitionExample :: HashMap Text Param
397paramsDefinitionExample :: HashMap Text Param
378paramsDefinitionExample =
398paramsDefinitionExample =
379 [ ("skipParam", mempty
399 [ ("skipParam", mempty
380− { _paramName = "skip"
400+ & name .~ "skip"
381− , _paramDescription = Just "number of items to skip"
401+ & description ?~ "number of items to skip"
382− , _paramRequired = Just True
402+ & required ?~ True
383− , _paramSchema = ParamOther $ mempty
403+ & schema .~ ParamOther (mempty
384− & paramOtherSchemaIn .~ ParamQuery
404+ & in_ .~ ParamQuery
385− & schemaType .~ SwaggerInteger
405+ & type_ ?~ SwaggerInteger
386− & schemaFormat ?~ "int32" })
406+ & format ?~ "int32" ))
387 , ("limitParam", mempty
407 , ("limitParam", mempty
388− { _paramName = "limit"
408+ & name .~ "limit"
389− , _paramDescription = Just "max records to return"
409+ & description ?~ "max records to return"
390− , _paramRequired = Just True
410+ & required ?~ True
391− , _paramSchema = ParamOther $ mempty
411+ & schema .~ ParamOther (mempty
392− & paramOtherSchemaIn .~ ParamQuery
412+ & in_ .~ ParamQuery
393− & schemaType .~ SwaggerInteger
413+ & type_ ?~ SwaggerInteger
394− & schemaFormat ?~ "int32" }) ]
414+ & format ?~ "int32" )) ]
395
415
396paramsDefinitionExampleJSON :: Value
416paramsDefinitionExampleJSON :: Value
397paramsDefinitionExampleJSON = [aesonQQ|
417paramsDefinitionExampleJSON = [aesonQQ|
@@ -421,8 +441,8 @@ paramsDefinitionExampleJSON = [aesonQQ|
421
441
422responsesDefinitionExample :: HashMap Text Response
442responsesDefinitionExample :: HashMap Text Response
423responsesDefinitionExample =
443responsesDefinitionExample =
424− [ ("NotFound", mempty { _responseDescription = "Entity not found." })
444+ [ ("NotFound", mempty & description .~ "Entity not found.")
425− , ("IllegalInput", mempty { _responseDescription = "Illegal input for operation." }) ]
445+ , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]
426
446
427responsesDefinitionExampleJSON :: Value
447responsesDefinitionExampleJSON :: Value
428responsesDefinitionExampleJSON = [aesonQQ|
448responsesDefinitionExampleJSON = [aesonQQ|
@@ -440,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
440-- Responses Definition object
460-- Responses Definition object
441-- =======================================================================
461-- =======================================================================
442
462
443−securityDefinitionsExample :: HashMap Text SecurityScheme
463+securityDefinitionsExample :: SecurityDefinitions
444−securityDefinitionsExample =
464+securityDefinitionsExample = SecurityDefinitions
445 [ ("api_key", SecurityScheme
465 [ ("api_key", SecurityScheme
446 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
447 , _securitySchemeDescription = Nothing })
467 , _securitySchemeDescription = Nothing })
@@ -473,51 +493,86 @@ securityDefinitionsExampleJSON = [aesonQQ|
473}
493}
474|]
494|]
475
495
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+
476-- =======================================================================
536-- =======================================================================
477-- Swagger object
537-- Swagger object
478-- =======================================================================
538-- =======================================================================
479
539
480swaggerExample :: Swagger
540swaggerExample :: Swagger
481swaggerExample = mempty
541swaggerExample = mempty
482− { _basePath = Just "/"
542+ & basePath ?~ "/"
483− , _schemes = Just [Http]
543+ & schemes ?~ [Http]
484− , _info = mempty
544+ & info .~ (mempty
485− { _infoVersion = "1.0"
545+ & version .~ "1.0"
486− , _infoTitle = "Todo API"
546+ & title .~ "Todo API"
487− , _infoLicense = Just License
547+ & license ?~ "MIT"
488− { _licenseName = "MIT"
489− , _licenseUrl = Just (URL "http://mit.com") }
548+ & license._Just.url ?~ URL "http://mit.com"
490− , _infoDescription = Just "This is a an API that tests servant-swagger support for a Todo API" }
549+ & description ?~ "This is a an API that tests servant-swagger support for a Todo API")
491− , _paths = mempty
492− { _pathsMap =
493− [ ("/todo/{id}", mempty
550+ & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)
494− { _pathItemGet = Just mempty
495− { _operationResponses = mempty
496− { _responsesResponses =
497− [ (200, Inline mempty
551+ & at 200 ?~ Inline (mempty
498− { _responseSchema = Just $ Inline (mempty & schemaType .~ SwaggerObject)
552+ & description .~ "OK"
499− { _schemaExample = Just [aesonQQ|
553+ & schema ?~ Inline (mempty
554+ & type_ ?~ SwaggerObject
555+ & example ?~ [aesonQQ|
500− {
556+ {
501− "created": 100,
557+ "created": 100,
502− "description": "get milk"
558+ "description": "get milk"
503− } |]
559+ } |]
504− , _schemaDescription = Just "This is some real Todo right here"
560+ & description ?~ "This is some real Todo right here"
505− , _schemaProperties =
561+ & properties .~
506− [ ("created", Inline $ mempty
562+ [ ("created", Inline $ mempty
507− & schemaType .~ SwaggerInteger
563+ & type_ ?~ SwaggerInteger
508− & schemaFormat ?~ "int32")
564+ & format ?~ "int32")
509− , ("description", Inline (mempty & schemaType .~ SwaggerString)) ] }
565+ , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
510− , _responseDescription = "OK" }) ] }
511− , _operationProduces = Just (MimeList [ "application/json" ])
566+ & produces ?~ MimeList [ "application/json" ]
512− , _operationParameters =
567+ & parameters .~
513− [ Inline mempty
568+ [ Inline $ mempty
514− { _paramRequired = Just True
569+ & required ?~ True
515− , _paramName = "id"
570+ & name .~ "id"
516− , _paramDescription = Just "TodoId param"
571+ & description ?~ "TodoId param"
517− , _paramSchema = ParamOther $ mempty
572+ & schema .~ ParamOther (mempty
518− & paramOtherSchemaIn .~ ParamPath
573+ & in_ .~ ParamPath
519− & schemaType .~ SwaggerString } ]
574+ & type_ ?~ SwaggerString ) ]
520− , _operationTags = [ "todo" ] } }) ] } }
575+ & tags .~ InsOrdHS.fromList [ "todo" ] ))
521
576
522swaggerExampleJSON :: Value
577swaggerExampleJSON :: Value
523swaggerExampleJSON = [aesonQQ|
578swaggerExampleJSON = [aesonQQ|
@@ -584,130 +639,130 @@ swaggerExampleJSON = [aesonQQ|
584
639
585petstoreExampleJSON :: Value
640petstoreExampleJSON :: Value
586petstoreExampleJSON = [aesonQQ|
641petstoreExampleJSON = [aesonQQ|
587−{
642+{
588 "swagger":"2.0",
643 "swagger":"2.0",
589− "info":{
644+ "info":{
590 "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.",
645 "description":"This is a sample server Petstore server. You can find out more about Swagger at [http://swagger.io](http://swagger.io) or on [irc.freenode.net, #swagger](http://swagger.io/irc/). For this sample, you can use the api key `special-key` to test the authorization filters.",
591 "version":"1.0.0",
646 "version":"1.0.0",
592 "title":"Swagger Petstore",
647 "title":"Swagger Petstore",
593 "termsOfService":"http://swagger.io/terms/",
648 "termsOfService":"http://swagger.io/terms/",
594− "contact":{
649+ "contact":{
595 "email":"apiteam@swagger.io"
650 "email":"apiteam@swagger.io"
596 },
651 },
597− "license":{
652+ "license":{
598 "name":"Apache 2.0",
653 "name":"Apache 2.0",
599 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
654 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
600 }
655 }
601 },
656 },
602 "host":"petstore.swagger.io",
657 "host":"petstore.swagger.io",
603 "basePath":"/v2",
658 "basePath":"/v2",
604− "tags":[
659+ "tags":[
605− {
660+ {
606 "name":"pet",
661 "name":"pet",
607 "description":"Everything about your Pets",
662 "description":"Everything about your Pets",
608− "externalDocs":{
663+ "externalDocs":{
609 "description":"Find out more",
664 "description":"Find out more",
610 "url":"http://swagger.io"
665 "url":"http://swagger.io"
611 }
666 }
612 },
667 },
613− {
668+ {
614 "name":"store",
669 "name":"store",
615 "description":"Access to Petstore orders"
670 "description":"Access to Petstore orders"
616 },
671 },
617− {
672+ {
618 "name":"user",
673 "name":"user",
619 "description":"Operations about user",
674 "description":"Operations about user",
620− "externalDocs":{
675+ "externalDocs":{
621 "description":"Find out more about our store",
676 "description":"Find out more about our store",
622 "url":"http://swagger.io"
677 "url":"http://swagger.io"
623 }
678 }
624 }
679 }
625 ],
680 ],
626− "schemes":[
681+ "schemes":[
627 "http"
682 "http"
628 ],
683 ],
629− "paths":{
684+ "paths":{
630− "/pet":{
685+ "/pet":{
631− "post":{
686+ "post":{
632− "tags":[
687+ "tags":[
633 "pet"
688 "pet"
634 ],
689 ],
635 "summary":"Add a new pet to the store",
690 "summary":"Add a new pet to the store",
636 "description":"",
691 "description":"",
637 "operationId":"addPet",
692 "operationId":"addPet",
638− "consumes":[
693+ "consumes":[
639 "application/json",
694 "application/json",
640 "application/xml"
695 "application/xml"
641 ],
696 ],
642− "produces":[
697+ "produces":[
643 "application/xml",
698 "application/xml",
644 "application/json"
699 "application/json"
645 ],
700 ],
646− "parameters":[
701+ "parameters":[
647− {
702+ {
648 "in":"body",
703 "in":"body",
649 "name":"body",
704 "name":"body",
650 "description":"Pet object that needs to be added to the store",
705 "description":"Pet object that needs to be added to the store",
651 "required":true,
706 "required":true,
652− "schema":{
707+ "schema":{
653 "$ref":"#/definitions/Pet"
708 "$ref":"#/definitions/Pet"
654 }
709 }
655 }
710 }
656 ],
711 ],
657− "responses":{
712+ "responses":{
658− "405":{
713+ "405":{
659 "description":"Invalid input"
714 "description":"Invalid input"
660 }
715 }
661 },
716 },
662− "security":[
717+ "security":[
663− {
718+ {
664− "petstore_auth":[
719+ "petstore_auth":[
665 "write:pets",
720 "write:pets",
666 "read:pets"
721 "read:pets"
667 ]
722 ]
668 }
723 }
669 ]
724 ]
670 },
725 },
671− "put":{
726+ "put":{
672− "tags":[
727+ "tags":[
673 "pet"
728 "pet"
674 ],
729 ],
675 "summary":"Update an existing pet",
730 "summary":"Update an existing pet",
676 "description":"",
731 "description":"",
677 "operationId":"updatePet",
732 "operationId":"updatePet",
678− "consumes":[
733+ "consumes":[
679 "application/json",
734 "application/json",
680 "application/xml"
735 "application/xml"
681 ],
736 ],
682− "produces":[
737+ "produces":[
683 "application/xml",
738 "application/xml",
684 "application/json"
739 "application/json"
685 ],
740 ],
686− "parameters":[
741+ "parameters":[
687− {
742+ {
688 "in":"body",
743 "in":"body",
689 "name":"body",
744 "name":"body",
690 "description":"Pet object that needs to be added to the store",
745 "description":"Pet object that needs to be added to the store",
691 "required":true,
746 "required":true,
692− "schema":{
747+ "schema":{
693 "$ref":"#/definitions/Pet"
748 "$ref":"#/definitions/Pet"
694 }
749 }
695 }
750 }
696 ],
751 ],
697− "responses":{
752+ "responses":{
698− "400":{
753+ "400":{
699 "description":"Invalid ID supplied"
754 "description":"Invalid ID supplied"
700 },
755 },
701− "404":{
756+ "404":{
702 "description":"Pet not found"
757 "description":"Pet not found"
703 },
758 },
704− "405":{
759+ "405":{
705 "description":"Validation exception"
760 "description":"Validation exception"
706 }
761 }
707 },
762 },
708− "security":[
763+ "security":[
709− {
764+ {
710− "petstore_auth":[
765+ "petstore_auth":[
711 "write:pets",
766 "write:pets",
712 "read:pets"
767 "read:pets"
713 ]
768 ]
@@ -715,28 +770,28 @@ petstoreExampleJSON = [aesonQQ|
715 ]
770 ]
716 }
771 }
717 },
772 },
718− "/pet/findByStatus":{
773+ "/pet/findByStatus":{
719− "get":{
774+ "get":{
720− "tags":[
775+ "tags":[
721 "pet"
776 "pet"
722 ],
777 ],
723 "summary":"Finds Pets by status",
778 "summary":"Finds Pets by status",
724 "description":"Multiple status values can be provided with comma seperated strings",
779 "description":"Multiple status values can be provided with comma seperated strings",
725 "operationId":"findPetsByStatus",
780 "operationId":"findPetsByStatus",
726− "produces":[
781+ "produces":[
727 "application/xml",
782 "application/xml",
728 "application/json"
783 "application/json"
729 ],
784 ],
730− "parameters":[
785+ "parameters":[
731− {
786+ {
732 "name":"status",
787 "name":"status",
733 "in":"query",
788 "in":"query",
734 "description":"Status values that need to be considered for filter",
789 "description":"Status values that need to be considered for filter",
735 "required":true,
790 "required":true,
736 "type":"array",
791 "type":"array",
737− "items":{
792+ "items":{
738 "type":"string",
793 "type":"string",
739− "enum":[
794+ "enum":[
740 "available",
795 "available",
741 "pending",
796 "pending",
742 "sold"
797 "sold"
@@ -746,23 +801,23 @@ petstoreExampleJSON = [aesonQQ|
746 "collectionFormat":"csv"
801 "collectionFormat":"csv"
747 }
802 }
748 ],
803 ],
749− "responses":{
804+ "responses":{
750− "200":{
805+ "200":{
751 "description":"successful operation",
806 "description":"successful operation",
752− "schema":{
807+ "schema":{
753 "type":"array",
808 "type":"array",
754− "items":{
809+ "items":{
755 "$ref":"#/definitions/Pet"
810 "$ref":"#/definitions/Pet"
756 }
811 }
757 }
812 }
758 },
813 },
759− "400":{
814+ "400":{
760 "description":"Invalid status value"
815 "description":"Invalid status value"
761 }
816 }
762 },
817 },
763− "security":[
818+ "security":[
764− {
819+ {
765− "petstore_auth":[
820+ "petstore_auth":[
766 "write:pets",
821 "write:pets",
767 "read:pets"
822 "read:pets"
768 ]
823 ]
@@ -770,48 +825,48 @@ petstoreExampleJSON = [aesonQQ|
770 ]
825 ]
771 }
826 }
772 },
827 },
773− "/pet/findByTags":{
828+ "/pet/findByTags":{
774− "get":{
829+ "get":{
775− "tags":[
830+ "tags":[
776 "pet"
831 "pet"
777 ],
832 ],
778 "summary":"Finds Pets by tags",
833 "summary":"Finds Pets by tags",
779 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
834 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
780 "operationId":"findPetsByTags",
835 "operationId":"findPetsByTags",
781− "produces":[
836+ "produces":[
782 "application/xml",
837 "application/xml",
783 "application/json"
838 "application/json"
784 ],
839 ],
785− "parameters":[
840+ "parameters":[
786− {
841+ {
787 "name":"tags",
842 "name":"tags",
788 "in":"query",
843 "in":"query",
789 "description":"Tags to filter by",
844 "description":"Tags to filter by",
790 "required":true,
845 "required":true,
791 "type":"array",
846 "type":"array",
792− "items":{
847+ "items":{
793 "type":"string"
848 "type":"string"
794 },
849 },
795 "collectionFormat":"csv"
850 "collectionFormat":"csv"
796 }
851 }
797 ],
852 ],
798− "responses":{
853+ "responses":{
799− "200":{
854+ "200":{
800 "description":"successful operation",
855 "description":"successful operation",
801− "schema":{
856+ "schema":{
802 "type":"array",
857 "type":"array",
803− "items":{
858+ "items":{
804 "$ref":"#/definitions/Pet"
859 "$ref":"#/definitions/Pet"
805 }
860 }
806 }
861 }
807 },
862 },
808− "400":{
863+ "400":{
809 "description":"Invalid tag value"
864 "description":"Invalid tag value"
810 }
865 }
811 },
866 },
812− "security":[
867+ "security":[
813− {
868+ {
814− "petstore_auth":[
869+ "petstore_auth":[
815 "write:pets",
870 "write:pets",
816 "read:pets"
871 "read:pets"
817 ]
872 ]
@@ -819,20 +874,20 @@ petstoreExampleJSON = [aesonQQ|
819 ]
874 ]
820 }
875 }
821 },
876 },
822− "/pet/{petId}":{
877+ "/pet/{petId}":{
823− "get":{
878+ "get":{
824− "tags":[
879+ "tags":[
825 "pet"
880 "pet"
826 ],
881 ],
827 "summary":"Find pet by ID",
882 "summary":"Find pet by ID",
828 "description":"Returns a single pet",
883 "description":"Returns a single pet",
829 "operationId":"getPetById",
884 "operationId":"getPetById",
830− "produces":[
885+ "produces":[
831 "application/xml",
886 "application/xml",
832 "application/json"
887 "application/json"
833 ],
888 ],
834− "parameters":[
889+ "parameters":[
835− {
890+ {
836 "name":"petId",
891 "name":"petId",
837 "in":"path",
892 "in":"path",
838 "description":"ID of pet to return",
893 "description":"ID of pet to return",
@@ -841,43 +896,42 @@ petstoreExampleJSON = [aesonQQ|
841 "format":"int64"
896 "format":"int64"
842 }
897 }
843 ],
898 ],
844− "responses":{
899+ "responses":{
845− "200":{
900+ "200":{
846 "description":"successful operation",
901 "description":"successful operation",
847− "schema":{
902+ "schema":{
848 "$ref":"#/definitions/Pet"
903 "$ref":"#/definitions/Pet"
849 }
904 }
850 },
905 },
851− "400":{
906+ "400":{
852 "description":"Invalid ID supplied"
907 "description":"Invalid ID supplied"
853 },
908 },
854− "404":{
909+ "404":{
855 "description":"Pet not found"
910 "description":"Pet not found"
856 }
911 }
857 },
912 },
858− "security":[
913+ "security":[
859− {
914+ {
860− "api_key":[
915+ "api_key": []
861− ]
862 }
916 }
863 ]
917 ]
864 },
918 },
865− "post":{
919+ "post":{
866− "tags":[
920+ "tags":[
867 "pet"
921 "pet"
868 ],
922 ],
869 "summary":"Updates a pet in the store with form data",
923 "summary":"Updates a pet in the store with form data",
870 "description":"",
924 "description":"",
871 "operationId":"updatePetWithForm",
925 "operationId":"updatePetWithForm",
872− "consumes":[
926+ "consumes":[
873 "application/x-www-form-urlencoded"
927 "application/x-www-form-urlencoded"
874 ],
928 ],
875− "produces":[
929+ "produces":[
876 "application/xml",
930 "application/xml",
877 "application/json"
931 "application/json"
878 ],
932 ],
879− "parameters":[
933+ "parameters":[
880− {
934+ {
881 "name":"petId",
935 "name":"petId",
882 "in":"path",
936 "in":"path",
883 "description":"ID of pet that needs to be updated",
937 "description":"ID of pet that needs to be updated",
@@ -885,14 +939,14 @@ petstoreExampleJSON = [aesonQQ|
885 "type":"integer",
939 "type":"integer",
886 "format":"int64"
940 "format":"int64"
887 },
941 },
888− {
942+ {
889 "name":"name",
943 "name":"name",
890 "in":"formData",
944 "in":"formData",
891 "description":"Updated name of the pet",
945 "description":"Updated name of the pet",
892 "required":false,
946 "required":false,
893 "type":"string"
947 "type":"string"
894 },
948 },
895− {
949+ {
896 "name":"status",
950 "name":"status",
897 "in":"formData",
951 "in":"formData",
898 "description":"Updated status of the pet",
952 "description":"Updated status of the pet",
@@ -900,39 +954,39 @@ petstoreExampleJSON = [aesonQQ|
900 "type":"string"
954 "type":"string"
901 }
955 }
902 ],
956 ],
903− "responses":{
957+ "responses":{
904− "405":{
958+ "405":{
905 "description":"Invalid input"
959 "description":"Invalid input"
906 }
960 }
907 },
961 },
908− "security":[
962+ "security":[
909− {
963+ {
910− "petstore_auth":[
964+ "petstore_auth":[
911 "write:pets",
965 "write:pets",
912 "read:pets"
966 "read:pets"
913 ]
967 ]
914 }
968 }
915 ]
969 ]
916 },
970 },
917− "delete":{
971+ "delete":{
918− "tags":[
972+ "tags":[
919 "pet"
973 "pet"
920 ],
974 ],
921 "summary":"Deletes a pet",
975 "summary":"Deletes a pet",
922 "description":"",
976 "description":"",
923 "operationId":"deletePet",
977 "operationId":"deletePet",
924− "produces":[
978+ "produces":[
925 "application/xml",
979 "application/xml",
926 "application/json"
980 "application/json"
927 ],
981 ],
928− "parameters":[
982+ "parameters":[
929− {
983+ {
930 "name":"api_key",
984 "name":"api_key",
931 "in":"header",
985 "in":"header",
932 "required":false,
986 "required":false,
933 "type":"string"
987 "type":"string"
934 },
988 },
935− {
989+ {
936 "name":"petId",
990 "name":"petId",
937 "in":"path",
991 "in":"path",
938 "description":"Pet id to delete",
992 "description":"Pet id to delete",
@@ -941,14 +995,14 @@ petstoreExampleJSON = [aesonQQ|
941 "format":"int64"
995 "format":"int64"
942 }
996 }
943 ],
997 ],
944− "responses":{
998+ "responses":{
945− "400":{
999+ "400":{
946 "description":"Invalid pet value"
1000 "description":"Invalid pet value"
947 }
1001 }
948 },
1002 },
949− "security":[
1003+ "security":[
950− {
1004+ {
951− "petstore_auth":[
1005+ "petstore_auth":[
952 "write:pets",
1006 "write:pets",
953 "read:pets"
1007 "read:pets"
954 ]
1008 ]
@@ -956,22 +1010,22 @@ petstoreExampleJSON = [aesonQQ|
956 ]
1010 ]
957 }
1011 }
958 },
1012 },
959− "/pet/{petId}/uploadImage":{
1013+ "/pet/{petId}/uploadImage":{
960− "post":{
1014+ "post":{
961− "tags":[
1015+ "tags":[
962 "pet"
1016 "pet"
963 ],
1017 ],
964 "summary":"uploads an image",
1018 "summary":"uploads an image",
965 "description":"",
1019 "description":"",
966 "operationId":"uploadFile",
1020 "operationId":"uploadFile",
967− "consumes":[
1021+ "consumes":[
968 "multipart/form-data"
1022 "multipart/form-data"
969 ],
1023 ],
970− "produces":[
1024+ "produces":[
971 "application/json"
1025 "application/json"
972 ],
1026 ],
973− "parameters":[
1027+ "parameters":[
974− {
1028+ {
975 "name":"petId",
1029 "name":"petId",
976 "in":"path",
1030 "in":"path",
977 "description":"ID of pet to update",
1031 "description":"ID of pet to update",
@@ -979,14 +1033,14 @@ petstoreExampleJSON = [aesonQQ|
979 "type":"integer",
1033 "type":"integer",
980 "format":"int64"
1034 "format":"int64"
981 },
1035 },
982− {
1036+ {
983 "name":"additionalMetadata",
1037 "name":"additionalMetadata",
984 "in":"formData",
1038 "in":"formData",
985 "description":"Additional data to pass to server",
1039 "description":"Additional data to pass to server",
986 "required":false,
1040 "required":false,
987 "type":"string"
1041 "type":"string"
988 },
1042 },
989− {
1043+ {
990 "name":"file",
1044 "name":"file",
991 "in":"formData",
1045 "in":"formData",
992 "description":"file to upload",
1046 "description":"file to upload",
@@ -994,17 +1048,17 @@ petstoreExampleJSON = [aesonQQ|
994 "type":"file"
1048 "type":"file"
995 }
1049 }
996 ],
1050 ],
997− "responses":{
1051+ "responses":{
998− "200":{
1052+ "200":{
999 "description":"successful operation",
1053 "description":"successful operation",
1000− "schema":{
1054+ "schema":{
1001 "$ref":"#/definitions/ApiResponse"
1055 "$ref":"#/definitions/ApiResponse"
1002 }
1056 }
1003 }
1057 }
1004 },
1058 },
1005− "security":[
1059+ "security":[
1006− {
1060+ {
1007− "petstore_auth":[
1061+ "petstore_auth":[
1008 "write:pets",
1062 "write:pets",
1009 "read:pets"
1063 "read:pets"
1010 ]
1064 ]
@@ -1012,89 +1066,87 @@ petstoreExampleJSON = [aesonQQ|
1012 ]
1066 ]
1013 }
1067 }
1014 },
1068 },
1015− "/store/inventory":{
1069+ "/store/inventory":{
1016− "get":{
1070+ "get":{
1017− "tags":[
1071+ "tags":[
1018 "store"
1072 "store"
1019 ],
1073 ],
1020 "summary":"Returns pet inventories by status",
1074 "summary":"Returns pet inventories by status",
1021 "description":"Returns a map of status codes to quantities",
1075 "description":"Returns a map of status codes to quantities",
1022 "operationId":"getInventory",
1076 "operationId":"getInventory",
1023− "produces":[
1077+ "produces":[
1024 "application/json"
1078 "application/json"
1025 ],
1079 ],
1026− "parameters":[
1080+ "parameters": [],
1027− ],
1028− "responses":{
1081+ "responses":{
1029− "200":{
1082+ "200":{
1030 "description":"successful operation",
1083 "description":"successful operation",
1031− "schema":{
1084+ "schema":{
1032 "type":"object",
1085 "type":"object",
1033− "additionalProperties":{
1086+ "additionalProperties":{
1034 "type":"integer",
1087 "type":"integer",
1035 "format":"int32"
1088 "format":"int32"
1036 }
1089 }
1037 }
1090 }
1038 }
1091 }
1039 },
1092 },
1040− "security":[
1093+ "security":[
1041− {
1094+ {
1042− "api_key":[
1095+ "api_key": []
1043− ]
1044 }
1096 }
1045 ]
1097 ]
1046 }
1098 }
1047 },
1099 },
1048− "/store/order":{
1100+ "/store/order":{
1049− "post":{
1101+ "post":{
1050− "tags":[
1102+ "tags":[
1051 "store"
1103 "store"
1052 ],
1104 ],
1053 "summary":"Place an order for a pet",
1105 "summary":"Place an order for a pet",
1054 "description":"",
1106 "description":"",
1055 "operationId":"placeOrder",
1107 "operationId":"placeOrder",
1056− "produces":[
1108+ "produces":[
1057 "application/xml",
1109 "application/xml",
1058 "application/json"
1110 "application/json"
1059 ],
1111 ],
1060− "parameters":[
1112+ "parameters":[
1061− {
1113+ {
1062 "in":"body",
1114 "in":"body",
1063 "name":"body",
1115 "name":"body",
1064 "description":"order placed for purchasing the pet",
1116 "description":"order placed for purchasing the pet",
1065 "required":true,
1117 "required":true,
1066− "schema":{
1118+ "schema":{
1067 "$ref":"#/definitions/Order"
1119 "$ref":"#/definitions/Order"
1068 }
1120 }
1069 }
1121 }
1070 ],
1122 ],
1071− "responses":{
1123+ "responses":{
1072− "200":{
1124+ "200":{
1073 "description":"successful operation",
1125 "description":"successful operation",
1074− "schema":{
1126+ "schema":{
1075 "$ref":"#/definitions/Order"
1127 "$ref":"#/definitions/Order"
1076 }
1128 }
1077 },
1129 },
1078− "400":{
1130+ "400":{
1079 "description":"Invalid Order"
1131 "description":"Invalid Order"
1080 }
1132 }
1081 }
1133 }
1082 }
1134 }
1083 },
1135 },
1084− "/store/order/{orderId}":{
1136+ "/store/order/{orderId}":{
1085− "get":{
1137+ "get":{
1086− "tags":[
1138+ "tags":[
1087 "store"
1139 "store"
1088 ],
1140 ],
1089 "summary":"Find purchase order by ID",
1141 "summary":"Find purchase order by ID",
1090 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
1142 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
1091 "operationId":"getOrderById",
1143 "operationId":"getOrderById",
1092− "produces":[
1144+ "produces":[
1093 "application/xml",
1145 "application/xml",
1094 "application/json"
1146 "application/json"
1095 ],
1147 ],
1096− "parameters":[
1148+ "parameters":[
1097− {
1149+ {
1098 "name":"orderId",
1150 "name":"orderId",
1099 "in":"path",
1151 "in":"path",
1100 "description":"ID of pet that needs to be fetched",
1152 "description":"ID of pet that needs to be fetched",
@@ -1105,34 +1157,34 @@ petstoreExampleJSON = [aesonQQ|
1105 "format":"int64"
1157 "format":"int64"
1106 }
1158 }
1107 ],
1159 ],
1108− "responses":{
1160+ "responses":{
1109− "200":{
1161+ "200":{
1110 "description":"successful operation",
1162 "description":"successful operation",
1111− "schema":{
1163+ "schema":{
1112 "$ref":"#/definitions/Order"
1164 "$ref":"#/definitions/Order"
1113 }
1165 }
1114 },
1166 },
1115− "400":{
1167+ "400":{
1116 "description":"Invalid ID supplied"
1168 "description":"Invalid ID supplied"
1117 },
1169 },
1118− "404":{
1170+ "404":{
1119 "description":"Order not found"
1171 "description":"Order not found"
1120 }
1172 }
1121 }
1173 }
1122 },
1174 },
1123− "delete":{
1175+ "delete":{
1124− "tags":[
1176+ "tags":[
1125 "store"
1177 "store"
1126 ],
1178 ],
1127 "summary":"Delete purchase order by ID",
1179 "summary":"Delete purchase order by ID",
1128 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
1180 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
1129 "operationId":"deleteOrder",
1181 "operationId":"deleteOrder",
1130− "produces":[
1182+ "produces":[
1131 "application/xml",
1183 "application/xml",
1132 "application/json"
1184 "application/json"
1133 ],
1185 ],
1134− "parameters":[
1186+ "parameters":[
1135− {
1187+ {
1136 "name":"orderId",
1188 "name":"orderId",
1137 "in":"path",
1189 "in":"path",
1138 "description":"ID of the order that needs to be deleted",
1190 "description":"ID of the order that needs to be deleted",
@@ -1141,133 +1193,133 @@ petstoreExampleJSON = [aesonQQ|
1141 "minimum":1.0
1193 "minimum":1.0
1142 }
1194 }
1143 ],
1195 ],
1144− "responses":{
1196+ "responses":{
1145− "400":{
1197+ "400":{
1146 "description":"Invalid ID supplied"
1198 "description":"Invalid ID supplied"
1147 },
1199 },
1148− "404":{
1200+ "404":{
1149 "description":"Order not found"
1201 "description":"Order not found"
1150 }
1202 }
1151 }
1203 }
1152 }
1204 }
1153 },
1205 },
1154− "/user":{
1206+ "/user":{
1155− "post":{
1207+ "post":{
1156− "tags":[
1208+ "tags":[
1157 "user"
1209 "user"
1158 ],
1210 ],
1159 "summary":"Create user",
1211 "summary":"Create user",
1160 "description":"This can only be done by the logged in user.",
1212 "description":"This can only be done by the logged in user.",
1161 "operationId":"createUser",
1213 "operationId":"createUser",
1162− "produces":[
1214+ "produces":[
1163 "application/xml",
1215 "application/xml",
1164 "application/json"
1216 "application/json"
1165 ],
1217 ],
1166− "parameters":[
1218+ "parameters":[
1167− {
1219+ {
1168 "in":"body",
1220 "in":"body",
1169 "name":"body",
1221 "name":"body",
1170 "description":"Created user object",
1222 "description":"Created user object",
1171 "required":true,
1223 "required":true,
1172− "schema":{
1224+ "schema":{
1173 "$ref":"#/definitions/User"
1225 "$ref":"#/definitions/User"
1174 }
1226 }
1175 }
1227 }
1176 ],
1228 ],
1177− "responses":{
1229+ "responses":{
1178− "default":{
1230+ "default":{
1179 "description":"successful operation"
1231 "description":"successful operation"
1180 }
1232 }
1181 }
1233 }
1182 }
1234 }
1183 },
1235 },
1184− "/user/createWithArray":{
1236+ "/user/createWithArray":{
1185− "post":{
1237+ "post":{
1186− "tags":[
1238+ "tags":[
1187 "user"
1239 "user"
1188 ],
1240 ],
1189 "summary":"Creates list of users with given input array",
1241 "summary":"Creates list of users with given input array",
1190 "description":"",
1242 "description":"",
1191 "operationId":"createUsersWithArrayInput",
1243 "operationId":"createUsersWithArrayInput",
1192− "produces":[
1244+ "produces":[
1193 "application/xml",
1245 "application/xml",
1194 "application/json"
1246 "application/json"
1195 ],
1247 ],
1196− "parameters":[
1248+ "parameters":[
1197− {
1249+ {
1198 "in":"body",
1250 "in":"body",
1199 "name":"body",
1251 "name":"body",
1200 "description":"List of user object",
1252 "description":"List of user object",
1201 "required":true,
1253 "required":true,
1202− "schema":{
1254+ "schema":{
1203 "type":"array",
1255 "type":"array",
1204− "items":{
1256+ "items":{
1205 "$ref":"#/definitions/User"
1257 "$ref":"#/definitions/User"
1206 }
1258 }
1207 }
1259 }
1208 }
1260 }
1209 ],
1261 ],
1210− "responses":{
1262+ "responses":{
1211− "default":{
1263+ "default":{
1212 "description":"successful operation"
1264 "description":"successful operation"
1213 }
1265 }
1214 }
1266 }
1215 }
1267 }
1216 },
1268 },
1217− "/user/createWithList":{
1269+ "/user/createWithList":{
1218− "post":{
1270+ "post":{
1219− "tags":[
1271+ "tags":[
1220 "user"
1272 "user"
1221 ],
1273 ],
1222 "summary":"Creates list of users with given input array",
1274 "summary":"Creates list of users with given input array",
1223 "description":"",
1275 "description":"",
1224 "operationId":"createUsersWithListInput",
1276 "operationId":"createUsersWithListInput",
1225− "produces":[
1277+ "produces":[
1226 "application/xml",
1278 "application/xml",
1227 "application/json"
1279 "application/json"
1228 ],
1280 ],
1229− "parameters":[
1281+ "parameters":[
1230− {
1282+ {
1231 "in":"body",
1283 "in":"body",
1232 "name":"body",
1284 "name":"body",
1233 "description":"List of user object",
1285 "description":"List of user object",
1234 "required":true,
1286 "required":true,
1235− "schema":{
1287+ "schema":{
1236 "type":"array",
1288 "type":"array",
1237− "items":{
1289+ "items":{
1238 "$ref":"#/definitions/User"
1290 "$ref":"#/definitions/User"
1239 }
1291 }
1240 }
1292 }
1241 }
1293 }
1242 ],
1294 ],
1243− "responses":{
1295+ "responses":{
1244− "default":{
1296+ "default":{
1245 "description":"successful operation"
1297 "description":"successful operation"
1246 }
1298 }
1247 }
1299 }
1248 }
1300 }
1249 },
1301 },
1250− "/user/login":{
1302+ "/user/login":{
1251− "get":{
1303+ "get":{
1252− "tags":[
1304+ "tags":[
1253 "user"
1305 "user"
1254 ],
1306 ],
1255 "summary":"Logs user into the system",
1307 "summary":"Logs user into the system",
1256 "description":"",
1308 "description":"",
1257 "operationId":"loginUser",
1309 "operationId":"loginUser",
1258− "produces":[
1310+ "produces":[
1259 "application/xml",
1311 "application/xml",
1260 "application/json"
1312 "application/json"
1261 ],
1313 ],
1262− "parameters":[
1314+ "parameters":[
1263− {
1315+ {
1264 "name":"username",
1316 "name":"username",
1265 "in":"query",
1317 "in":"query",
1266 "description":"The user name for login",
1318 "description":"The user name for login",
1267 "required":true,
1319 "required":true,
1268 "type":"string"
1320 "type":"string"
1269 },
1321 },
1270− {
1322+ {
1271 "name":"password",
1323 "name":"password",
1272 "in":"query",
1324 "in":"query",
1273 "description":"The password for login in clear text",
1325 "description":"The password for login in clear text",
@@ -1275,66 +1327,65 @@ petstoreExampleJSON = [aesonQQ|
1275 "type":"string"
1327 "type":"string"
1276 }
1328 }
1277 ],
1329 ],
1278− "responses":{
1330+ "responses":{
1279− "200":{
1331+ "200":{
1280 "description":"successful operation",
1332 "description":"successful operation",
1281− "schema":{
1333+ "schema":{
1282 "type":"string"
1334 "type":"string"
1283 },
1335 },
1284− "headers":{
1336+ "headers":{
1285− "X-Rate-Limit":{
1337+ "X-Rate-Limit":{
1286 "type":"integer",
1338 "type":"integer",
1287 "format":"int32",
1339 "format":"int32",
1288 "description":"calls per hour allowed by the user"
1340 "description":"calls per hour allowed by the user"
1289 },
1341 },
1290− "X-Expires-After":{
1342+ "X-Expires-After":{
1291 "type":"string",
1343 "type":"string",
1292 "format":"date-time",
1344 "format":"date-time",
1293 "description":"date in UTC when toekn expires"
1345 "description":"date in UTC when toekn expires"
1294 }
1346 }
1295 }
1347 }
1296 },
1348 },
1297− "400":{
1349+ "400":{
1298 "description":"Invalid username/password supplied"
1350 "description":"Invalid username/password supplied"
1299 }
1351 }
1300 }
1352 }
1301 }
1353 }
1302 },
1354 },
1303− "/user/logout":{
1355+ "/user/logout":{
1304− "get":{
1356+ "get":{
1305− "tags":[
1357+ "tags":[
1306 "user"
1358 "user"
1307 ],
1359 ],
1308 "summary":"Logs out current logged in user session",
1360 "summary":"Logs out current logged in user session",
1309 "description":"",
1361 "description":"",
1310 "operationId":"logoutUser",
1362 "operationId":"logoutUser",
1311− "produces":[
1363+ "produces":[
1312 "application/xml",
1364 "application/xml",
1313 "application/json"
1365 "application/json"
1314 ],
1366 ],
1315− "parameters":[
1367+ "parameters": [],
1316− ],
1317− "responses":{
1368+ "responses":{
1318− "default":{
1369+ "default":{
1319 "description":"successful operation"
1370 "description":"successful operation"
1320 }
1371 }
1321 }
1372 }
1322 }
1373 }
1323 },
1374 },
1324− "/user/{username}":{
1375+ "/user/{username}":{
1325− "get":{
1376+ "get":{
1326− "tags":[
1377+ "tags":[
1327 "user"
1378 "user"
1328 ],
1379 ],
1329 "summary":"Get user by user name",
1380 "summary":"Get user by user name",
1330 "description":"",
1381 "description":"",
1331 "operationId":"getUserByName",
1382 "operationId":"getUserByName",
1332− "produces":[
1383+ "produces":[
1333 "application/xml",
1384 "application/xml",
1334 "application/json"
1385 "application/json"
1335 ],
1386 ],
1336− "parameters":[
1387+ "parameters":[
1337− {
1388+ {
1338 "name":"username",
1389 "name":"username",
1339 "in":"path",
1390 "in":"path",
1340 "description":"The name that needs to be fetched. Use user1 for testing. ",
1391 "description":"The name that needs to be fetched. Use user1 for testing. ",
@@ -1342,72 +1393,72 @@ petstoreExampleJSON = [aesonQQ|
1342 "type":"string"
1393 "type":"string"
1343 }
1394 }
1344 ],
1395 ],
1345− "responses":{
1396+ "responses":{
1346− "200":{
1397+ "200":{
1347 "description":"successful operation",
1398 "description":"successful operation",
1348− "schema":{
1399+ "schema":{
1349 "$ref":"#/definitions/User"
1400 "$ref":"#/definitions/User"
1350 }
1401 }
1351 },
1402 },
1352− "400":{
1403+ "400":{
1353 "description":"Invalid username supplied"
1404 "description":"Invalid username supplied"
1354 },
1405 },
1355− "404":{
1406+ "404":{
1356 "description":"User not found"
1407 "description":"User not found"
1357 }
1408 }
1358 }
1409 }
1359 },
1410 },
1360− "put":{
1411+ "put":{
1361− "tags":[
1412+ "tags":[
1362 "user"
1413 "user"
1363 ],
1414 ],
1364 "summary":"Updated user",
1415 "summary":"Updated user",
1365 "description":"This can only be done by the logged in user.",
1416 "description":"This can only be done by the logged in user.",
1366 "operationId":"updateUser",
1417 "operationId":"updateUser",
1367− "produces":[
1418+ "produces":[
1368 "application/xml",
1419 "application/xml",
1369 "application/json"
1420 "application/json"
1370 ],
1421 ],
1371− "parameters":[
1422+ "parameters":[
1372− {
1423+ {
1373 "name":"username",
1424 "name":"username",
1374 "in":"path",
1425 "in":"path",
1375 "description":"name that need to be deleted",
1426 "description":"name that need to be deleted",
1376 "required":true,
1427 "required":true,
1377 "type":"string"
1428 "type":"string"
1378 },
1429 },
1379− {
1430+ {
1380 "in":"body",
1431 "in":"body",
1381 "name":"body",
1432 "name":"body",
1382 "description":"Updated user object",
1433 "description":"Updated user object",
1383 "required":true,
1434 "required":true,
1384− "schema":{
1435+ "schema":{
1385 "$ref":"#/definitions/User"
1436 "$ref":"#/definitions/User"
1386 }
1437 }
1387 }
1438 }
1388 ],
1439 ],
1389− "responses":{
1440+ "responses":{
1390− "400":{
1441+ "400":{
1391 "description":"Invalid user supplied"
1442 "description":"Invalid user supplied"
1392 },
1443 },
1393− "404":{
1444+ "404":{
1394 "description":"User not found"
1445 "description":"User not found"
1395 }
1446 }
1396 }
1447 }
1397 },
1448 },
1398− "delete":{
1449+ "delete":{
1399− "tags":[
1450+ "tags":[
1400 "user"
1451 "user"
1401 ],
1452 ],
1402 "summary":"Delete user",
1453 "summary":"Delete user",
1403 "description":"This can only be done by the logged in user.",
1454 "description":"This can only be done by the logged in user.",
1404 "operationId":"deleteUser",
1455 "operationId":"deleteUser",
1405− "produces":[
1456+ "produces":[
1406 "application/xml",
1457 "application/xml",
1407 "application/json"
1458 "application/json"
1408 ],
1459 ],
1409− "parameters":[
1460+ "parameters":[
1410− {
1461+ {
1411 "name":"username",
1462 "name":"username",
1412 "in":"path",
1463 "in":"path",
1413 "description":"The name that needs to be deleted",
1464 "description":"The name that needs to be deleted",
@@ -1415,207 +1466,237 @@ petstoreExampleJSON = [aesonQQ|
1415 "type":"string"
1466 "type":"string"
1416 }
1467 }
1417 ],
1468 ],
1418− "responses":{
1469+ "responses":{
1419− "400":{
1470+ "400":{
1420 "description":"Invalid username supplied"
1471 "description":"Invalid username supplied"
1421 },
1472 },
1422− "404":{
1473+ "404":{
1423 "description":"User not found"
1474 "description":"User not found"
1424 }
1475 }
1425 }
1476 }
1426 }
1477 }
1427 }
1478 }
1428 },
1479 },
1429− "securityDefinitions":{
1480+ "securityDefinitions":{
1430− "petstore_auth":{
1481+ "petstore_auth":{
1431 "type":"oauth2",
1482 "type":"oauth2",
1432 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
1483 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
1433 "flow":"implicit",
1484 "flow":"implicit",
1434− "scopes":{
1485+ "scopes":{
1435 "write:pets":"modify pets in your account",
1486 "write:pets":"modify pets in your account",
1436 "read:pets":"read your pets"
1487 "read:pets":"read your pets"
1437 }
1488 }
1438 },
1489 },
1439− "api_key":{
1490+ "api_key":{
1440 "type":"apiKey",
1491 "type":"apiKey",
1441 "name":"api_key",
1492 "name":"api_key",
1442 "in":"header"
1493 "in":"header"
1443 }
1494 }
1444 },
1495 },
1445− "definitions":{
1496+ "definitions":{
1446− "Order":{
1497+ "Order":{
1447 "type":"object",
1498 "type":"object",
1448− "properties":{
1499+ "properties":{
1449− "id":{
1500+ "id":{
1450 "type":"integer",
1501 "type":"integer",
1451 "format":"int64"
1502 "format":"int64"
1452 },
1503 },
1453− "petId":{
1504+ "petId":{
1454 "type":"integer",
1505 "type":"integer",
1455 "format":"int64"
1506 "format":"int64"
1456 },
1507 },
1457− "quantity":{
1508+ "quantity":{
1458 "type":"integer",
1509 "type":"integer",
1459 "format":"int32"
1510 "format":"int32"
1460 },
1511 },
1461− "shipDate":{
1512+ "shipDate":{
1462 "type":"string",
1513 "type":"string",
1463 "format":"date-time"
1514 "format":"date-time"
1464 },
1515 },
1465− "status":{
1516+ "status":{
1466 "type":"string",
1517 "type":"string",
1467 "description":"Order Status",
1518 "description":"Order Status",
1468− "enum":[
1519+ "enum":[
1469 "placed",
1520 "placed",
1470 "approved",
1521 "approved",
1471 "delivered"
1522 "delivered"
1472 ]
1523 ]
1473 },
1524 },
1474− "complete":{
1525+ "complete":{
1475 "type":"boolean",
1526 "type":"boolean",
1476 "default":false
1527 "default":false
1477 }
1528 }
1478 },
1529 },
1479− "xml":{
1530+ "xml":{
1480 "name":"Order"
1531 "name":"Order"
1481 }
1532 }
1482 },
1533 },
1483− "Category":{
1534+ "Category":{
1484 "type":"object",
1535 "type":"object",
1485− "properties":{
1536+ "properties":{
1486− "id":{
1537+ "id":{
1487 "type":"integer",
1538 "type":"integer",
1488 "format":"int64"
1539 "format":"int64"
1489 },
1540 },
1490− "name":{
1541+ "name":{
1491 "type":"string"
1542 "type":"string"
1492 }
1543 }
1493 },
1544 },
1494− "xml":{
1545+ "xml":{
1495 "name":"Category"
1546 "name":"Category"
1496 }
1547 }
1497 },
1548 },
1498− "User":{
1549+ "User":{
1499 "type":"object",
1550 "type":"object",
1500− "properties":{
1551+ "properties":{
1501− "id":{
1552+ "id":{
1502 "type":"integer",
1553 "type":"integer",
1503 "format":"int64"
1554 "format":"int64"
1504 },
1555 },
1505− "username":{
1556+ "username":{
1506 "type":"string"
1557 "type":"string"
1507 },
1558 },
1508− "firstName":{
1559+ "firstName":{
1509 "type":"string"
1560 "type":"string"
1510 },
1561 },
1511− "lastName":{
1562+ "lastName":{
1512 "type":"string"
1563 "type":"string"
1513 },
1564 },
1514− "email":{
1565+ "email":{
1515 "type":"string"
1566 "type":"string"
1516 },
1567 },
1517− "password":{
1568+ "password":{
1518 "type":"string"
1569 "type":"string"
1519 },
1570 },
1520− "phone":{
1571+ "phone":{
1521 "type":"string"
1572 "type":"string"
1522 },
1573 },
1523− "userStatus":{
1574+ "userStatus":{
1524 "type":"integer",
1575 "type":"integer",
1525 "format":"int32",
1576 "format":"int32",
1526 "description":"User Status"
1577 "description":"User Status"
1527 }
1578 }
1528 },
1579 },
1529− "xml":{
1580+ "xml":{
1530 "name":"User"
1581 "name":"User"
1531 }
1582 }
1532 },
1583 },
1533− "Tag":{
1584+ "Tag":{
1534 "type":"object",
1585 "type":"object",
1535− "properties":{
1586+ "properties":{
1536− "id":{
1587+ "id":{
1537 "type":"integer",
1588 "type":"integer",
1538 "format":"int64"
1589 "format":"int64"
1539 },
1590 },
1540− "name":{
1591+ "name":{
1541 "type":"string"
1592 "type":"string"
1542 }
1593 }
1543 },
1594 },
1544− "xml":{
1595+ "xml":{
1545 "name":"Tag"
1596 "name":"Tag"
1546 }
1597 }
1547 },
1598 },
1548− "Pet":{
1599+ "Pet":{
1549 "type":"object",
1600 "type":"object",
1550− "required":[
1601+ "required":[
1551 "name",
1602 "name",
1552 "photoUrls"
1603 "photoUrls"
1553 ],
1604 ],
1554− "properties":{
1605+ "properties":{
1555− "id":{
1606+ "id":{
1556 "type":"integer",
1607 "type":"integer",
1557 "format":"int64"
1608 "format":"int64"
1558 },
1609 },
1559− "category":{
1610+ "category":{
1560 "$ref":"#/definitions/Category"
1611 "$ref":"#/definitions/Category"
1561 },
1612 },
1562− "name":{
1613+ "name":{
1563 "type":"string",
1614 "type":"string",
1564 "example":"doggie"
1615 "example":"doggie"
1565 },
1616 },
1566− "photoUrls":{
1617+ "photoUrls":{
1567 "type":"array",
1618 "type":"array",
1568− "xml":{
1619+ "xml":{
1569 "name":"photoUrl",
1620 "name":"photoUrl",
1570 "wrapped":true
1621 "wrapped":true
1571 },
1622 },
1572− "items":{
1623+ "items":{
1573 "type":"string"
1624 "type":"string"
1574 }
1625 }
1575 },
1626 },
1576− "tags":{
1627+ "tags":{
1577 "type":"array",
1628 "type":"array",
1578− "xml":{
1629+ "xml":{
1579 "name":"tag",
1630 "name":"tag",
1580 "wrapped":true
1631 "wrapped":true
1581 },
1632 },
1582− "items":{
1633+ "items":{
1583 "$ref":"#/definitions/Tag"
1634 "$ref":"#/definitions/Tag"
1584 }
1635 }
1585 },
1636 },
1586− "status":{
1637+ "status":{
1587 "type":"string",
1638 "type":"string",
1588 "description":"pet status in the store",
1639 "description":"pet status in the store",
1589− "enum":[
1640+ "enum":[
1590 "available",
1641 "available",
1591 "pending",
1642 "pending",
1592 "sold"
1643 "sold"
1593 ]
1644 ]
1594 }
1645 }
1595 },
1646 },
1596− "xml":{
1647+ "xml":{
1597 "name":"Pet"
1648 "name":"Pet"
1598 }
1649 }
1599 },
1650 },
1600− "ApiResponse":{
1651+ "ApiResponse":{
1601 "type":"object",
1652 "type":"object",
1602− "properties":{
1653+ "properties":{
1603− "code":{
1654+ "code":{
1604 "type":"integer",
1655 "type":"integer",
1605 "format":"int32"
1656 "format":"int32"
1606 },
1657 },
1607− "type":{
1658+ "type":{
1608 "type":"string"
1659 "type":"string"
1609 },
1660 },
1610− "message":{
1661+ "message":{
1611 "type":"string"
1662 "type":"string"
1612 }
1663 }
1613 }
1664 }
1614 }
1665 }
1615 },
1666 },
1616− "externalDocs":{
1667+ "externalDocs":{
1617 "description":"Find out more about Swagger",
1668 "description":"Find out more about Swagger",
1618 "url":"http://swagger.io"
1669 "url":"http://swagger.io"
1619 }
1670 }
1620}
1671}
1621|]
1672|]
1673+
1674+compositionSchemaExample :: Schema
1675+compositionSchemaExample = mempty
1676+ & type_ ?~ SwaggerObject
1677+ & Data.Swagger.allOf ?~ [
1678+ Ref (Reference "Other")
1679+ , Inline (mempty
1680+ & type_ ?~ SwaggerObject
1681+ & properties .~
1682+ [ ("greet", Inline $ mempty
1683+ & type_ ?~ SwaggerString) ])
1684+ ]
1685+
1686+compositionSchemaExampleJSON :: Value
1687+compositionSchemaExampleJSON = [aesonQQ|
1688+{
1689+ "type": "object",
1690+ "allOf": [
1691+ {
1692+ "$ref": "#/definitions/Other"
1693+ },
1694+ {
1695+ "type": "object",
1696+ "properties": {
1697+ "greet": { "type": "string" }
1698+ }
1699+ }
1700+ ]
1701+}
1702+|]
test/DocTest.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Main (main) where
2−
3−import System.FilePath.Glob (glob)
4−import Test.DocTest (doctest)
5−
6−main :: IO ()
7−main = glob "src/**/*.hs" >>= doctest
test/SpecCommon.hs+7−9
@@ -1,6 +1,7 @@
1module SpecCommon where
1module SpecCommon where
2
2
3import Data.Aeson
3import Data.Aeson
4+import Data.ByteString.Builder (toLazyByteString)
4import qualified Data.Foldable as F
5import qualified Data.Foldable as F
5import qualified Data.HashMap.Strict as HashMap
6import qualified Data.HashMap.Strict as HashMap
6import qualified Data.Vector as Vector
7import qualified Data.Vector as Vector
@@ -15,18 +16,15 @@ isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i
15isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)
16isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)
16isSubJSON x y = x == y
17isSubJSON x y = x == y
17
18
18−(<~>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
19−x <~> js = do
20− it "encodes correctly (probably with extra properties)" $ do
21− toJSON x `shouldSatisfy` (js `isSubJSON`)
22− it "decodes correctly" $ do
23− fromJSON js `shouldBe` Success x
24−
25(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
19(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
26x <=> js = do
20x <=> js = do
27 it "encodes correctly" $ do
21 it "encodes correctly" $ do
28 toJSON x `shouldBe` js
22 toJSON x `shouldBe` js
29 it "decodes correctly" $ do
23 it "decodes correctly" $ do
30 fromJSON js `shouldBe` Success x
24 fromJSON js `shouldBe` Success x
31−
25+ it "roundtrips: eitherDecode . encode" $ do
32−
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