git.iko.soy/typeable/swagger2
on 103d733 help sign in
39 files changed+352−9174
since splitsnapshots
unifiedsplit
.ghci−2 .gitignore−2 .travis.yml−162 CHANGELOG.md−305 LICENSE+1−1 README.md−37 Setup.hs−31 cabal.project−2 examples/hackage.hs−86 hackage-docs.sh−78 include/overlapping-compat.h−8 src/Data/Swagger.hs−345 src/Data/Swagger/Declare.hs−199 src/Data/Swagger/Internal.hs+335−1138 src/Data/Swagger/Internal/AesonUtils.hs−346 src/Data/Swagger/Internal/ParamSchema.hs−337 src/Data/Swagger/Internal/Schema.hs−882 src/Data/Swagger/Internal/Schema/Validation.hs−511 src/Data/Swagger/Internal/TypeShape.hs−66 src/Data/Swagger/Internal/Utils.hs−133 src/Data/Swagger/Lens.hs−186 src/Data/Swagger/Operation.hs−193 src/Data/Swagger/Optics.hs−597 src/Data/Swagger/ParamSchema.hs−26 src/Data/Swagger/Schema.hs−61 src/Data/Swagger/Schema/Generator.hs−114 src/Data/Swagger/Schema/Validation.hs−90 src/Data/Swagger/SchemaOptions.hs−72 stack.yaml+2−6 swagger2.cabal+14−134 test/Data/Swagger/CommonTestTypes.hs−679 test/Data/Swagger/ParamSchemaSpec.hs−40 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs−278 test/Data/Swagger/SchemaSpec.hs−114 test/Data/SwaggerSpec.hs−1702 test/Spec.hs−1 test/SpecCommon.hs−30 test/doctests.hs−12
.ghcideleted−2
@@ -1,2 +0,0 @@
1−:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/autogen/cabal_macros.h -optP-I -optPinclude
2−:set -hide-package base-compat-0.10.4
.gitignore−2
@@ -1,6 +1,4 @@
11dist
2−dist-newstyle
3−.ghc.environment.*
42cabal-dev
53*.o
64*.hi
.travis.ymldeleted−162
@@ -1,162 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.5.20191020
8−#
9−language: c
10−dist: xenial
11−git:
12− # whether to recursively clone submodules
13− submodules: false
14−branches:
15− only:
16− - master
17−cache:
18− directories:
19− - $HOME/.cabal/packages
20− - $HOME/.cabal/store
21−before_cache:
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
23− # remove files that are regenerated by 'cabal update'
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
27− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
28− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
29− - rm -rfv $CABALHOME/packages/head.hackage
30−matrix:
31− include:
32− - compiler: ghc-8.8.1
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
34− - compiler: ghc-8.6.5
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
36− - compiler: ghc-8.4.4
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
38− - compiler: ghc-8.2.2
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
40− - compiler: ghc-8.0.2
41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
42−before_install:
43− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
44− - WITHCOMPILER="-w $HC"
45− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
46− - HCPKG="$HC-pkg"
47− - unset CC
48− - CABAL=/opt/ghc/bin/cabal
49− - CABALHOME=$HOME/.cabal
50− - export PATH="$CABALHOME/bin:$PATH"
51− - TOP=$(pwd)
52− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
53− - echo $HCNUMVER
54− - CABAL="$CABAL -vnormal+nowrap+markoutput"
55− - set -o pipefail
56− - |
57− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
58− echo 'BEGIN { state = "output"; }' >> .colorful.awk
59− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
60− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
61− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
62− echo ' if (state == "cabal") {' >> .colorful.awk
63− echo ' print blue($0)' >> .colorful.awk
64− echo ' } else {' >> .colorful.awk
65− echo ' print $0' >> .colorful.awk
66− echo ' }' >> .colorful.awk
67− echo '}' >> .colorful.awk
68− - cat .colorful.awk
69− - |
70− color_cabal_output () {
71− awk -f $TOP/.colorful.awk
72− }
73− - echo text | color_cabal_output
74−install:
75− - ${CABAL} --version
76− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
77− - TEST=--enable-tests
78− - BENCH=--enable-benchmarks
79− - HEADHACKAGE=false
80− - rm -f $CABALHOME/config
81− - |
82− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
83− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
84− echo "write-ghc-environment-files: always" >> $CABALHOME/config
85− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
86− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
87− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
88− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
89− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
90− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
91− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
92− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
93− echo "install-dirs user" >> $CABALHOME/config
94− echo " prefix: $CABALHOME" >> $CABALHOME/config
95− echo "repository hackage.haskell.org" >> $CABALHOME/config
96− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
97− echo " secure: True" >> $CABALHOME/config
98− echo " key-threshold: 3" >> $CABALHOME/config
99− echo " root-keys:" >> $CABALHOME/config
100− echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config
101− echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config
102− echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config
103− echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config
104− echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config
105− - |
106− echo "program-default-options" >> $CABALHOME/config
107− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
108− - cat $CABALHOME/config
109− - rm -fv cabal.project cabal.project.local cabal.project.freeze
110− - travis_retry ${CABAL} v2-update -v
111− # Generate cabal.project
112− - rm -rf cabal.project cabal.project.local cabal.project.freeze
113− - touch cabal.project
114− - |
115− echo "packages: ." >> cabal.project
116− - |
117− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
118− - cat cabal.project || true
119− - cat cabal.project.local || true
120− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
121− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
122− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
123− - rm cabal.project.freeze
124− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
125− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
126−script:
127− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
128− # Packaging...
129− - ${CABAL} v2-sdist all | color_cabal_output
130− # Unpacking...
131− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
132− - cd ${DISTDIR} || false
133− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
134− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
135− - PKGDIR_swagger2="$(find . -maxdepth 1 -type d -regex '.*/swagger2-[0-9.]*')"
136− # Generate cabal.project
137− - rm -rf cabal.project cabal.project.local cabal.project.freeze
138− - touch cabal.project
139− - |
140− echo "packages: ${PKGDIR_swagger2}" >> cabal.project
141− - |
142− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
143− - cat cabal.project || true
144− - cat cabal.project.local || true
145− # Building...
146− # this builds all libraries and executables (without tests/benchmarks)
147− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
148− # Building with tests and benchmarks...
149− # build & run tests, build benchmarks
150− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
151− # Testing...
152− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
153− # cabal check...
154− - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)
155− # haddock...
156− - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi
157− # Building without installed constraints for packages in global-db...
158− - rm -f cabal.project.local
159− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
160−
161−# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
162−# EOF
CHANGELOG.mddeleted−305
@@ -1,305 +0,0 @@
1−2.5
2−---
3−
4−Highlights:
5−- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));
6−- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));
7−- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));
8−
9−Fixes and minor changes:
10−- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));
11−- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));
12−- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));
13−
14−2.4
15−---
16−
17−- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5
18−- Tags aren't sorted
19− (see [#165](https://github.com/GetShopTV/swagger2/issues/165))
20−- Schema type is optional
21− (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))
22−- Take concrete 'Proxy' as argument
23− (see [#180](https://github.com/GetShopTV/swagger2/pull/180))
24−- GHC-8.8 preparations
25−
26−2.3.1.1
27−-------
28−
29−- Allow `network-3.0`
30−
31−2.3.1
32−-----
33−
34−- Add a quickcheck generator for aeson Values that match a swagger schema
35− (see [#162](https://github.com/GetShopTV/swagger2/pull/162))
36−- Add `ToParamSchema` instance for `SetCookie`
37− (see [#173](https://github.com/GetShopTV/swagger2/pull/173))
38−- Make nullary schemas valid
39− (see [#168](https://github.com/GetShopTV/swagger2/pull/168))
40−
41−2.3.0.1
42−-------
43−
44−- Support GHC-8.6
45−
46−2.3
47−---
48−
49−Major changes:
50−
51−- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));
52−- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));
53−
54−Dependencies and CI:
55−
56−- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));
57−- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));
58−- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));
59−- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));
60−
61−2.2.2
62−-----
63−
64−* Add `ToSchema Version` instance
65−* Use base-compat-batteries (0.10)
66−* PVP bounds
67−
68−2.2.1
69−-----
70−
71−* Add `Semigroup` instances
72−* GHC-8.4 compatibility
73−* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))
74−* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))
75−* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))
76−* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))
77−
78−2.2
79−---
80−
81−* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
82−* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
83−* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):
84− * `genericNameSchema` — to give a custom schema `Generic`-based name;
85− * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;
86− * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;
87−* Add a few tests with invalid `Schema`.
88−
89−2.1.6
90−-----
91−
92−* Add `ToParamSchema` and `ToSchema` instances for `Fixed` (see [#121](https://github.com/GetShopTV/swagger2/pull/121)) and `Natural` (see [#123](https://github.com/GetShopTV/swagger2/pull/123));
93−* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));
94−* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).
95−
96−2.1.5
97−-----
98−
99−* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));
100−* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));
101−* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));
102−* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).
103−
104−2.1.4.1
105−-------
106−
107−* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108));
108−* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));
109−* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));
110−* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).
111−
112−2.1.4
113−-----
114−
115−* Add `liftDeclare` (see [#100](https://github.com/GetShopTV/swagger2/pull/100));
116−* Add `MonadDeclare` instances for all monad transformers (see [#100](https://github.com/GetShopTV/swagger2/pull/100)).
117−
118−2.1.3
119−-----
120−
121−* Add [`UUID`](http://hackage.haskell.org/package/uuid-types/docs/Data-UUID-Types.html#t:UUID) instances (see [#81](https://github.com/GetShopTV/swagger2/pull/81)).
122−* Add [`TypeError`](https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-TypeLits.html#g:4) `ToSchema` and `ToParamSchema ByteString` instances (see [#78](https://github.com/GetShopTV/swagger2/pull/78))
123−* Improve documentation for generic sum type instance derivation (see [#75](https://github.com/GetShopTV/swagger2/pull/75))
124−* Compile warning free (see [#82](https://github.com/GetShopTV/swagger2/pull/82))
125−
126−2.1.2.1
127−-------
128−
129−* Bug fix previous release
130−
131−2.1.2
132−---
133−
134−* Minor changes:
135− * Support `aeson-1.0.0.0` (see [#70](https://github.com/GetShopTV/swagger2/pull/70)).
136−
137−2.1.1
138−---
139−
140−* Minor changes:
141− * Proper `Schema` examples for `Char`, `Day`, `LocalTime`, `ZonedTime` and `UTCTime`.
142−
143−2.1
144−---
145−
146−* Major changes:
147− * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));
148− * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).
149−
150−2.0.2
151−---
152−
153−* Fixes:
154− * Fix `additionalProperties` to allow references;
155− * Fix `ToSchema` instances for `Map` and `HashMap` (prevent infinite recursion for recursive values).
156−
157−2.0.1
158−---
159−
160−* Fixes:
161− * Re-export `Pattern` synonym from `Data.Swagger`;
162− * Documentation fixes.
163−
164−2.0
165−---
166−
167−* Major changes:
168− * GHC 7.8 support (see [#49](https://github.com/GetShopTV/swagger2/pull/49));
169− * Switch to classy field lenses (see [#41](https://github.com/GetShopTV/swagger2/pull/41));
170− * Add `Data.Swagger.Schema.Validation` (see [#18](https://github.com/GetShopTV/swagger2/pull/18));
171− * Add `Data.Swagger.Operation` with helpers (see [#50](https://github.com/GetShopTV/swagger2/pull/50));
172− * Add `IsString` instances for some types (see [#47](https://github.com/GetShopTV/swagger2/pull/47));
173− * Add helpers to sketch `Schema` from JSON (see [#48](https://github.com/GetShopTV/swagger2/pull/48)).
174−
175−* Minor changes:
176− * Make `NamedSchema` a `data` rather than `type` (see [#42](https://github.com/GetShopTV/swagger2/pull/42));
177− * Change `Definitions` to `Definitions Schema`;
178− * Add schema templates for `"binary"`, `"byte"` and `"password"` formats (see [63ed597](https://github.com/GetShopTV/swagger2/commit/63ed59736dc4f942f0e2a7d668d7cee513fa9eaf));
179− * Add `Monoid` instance for `Contact`;
180− * Change `tags` to be `Set` rather than list.
181−
182−* Fixes:
183− * Fix schema for `()` and nullary constructors (see [ab65c4a](https://github.com/GetShopTV/swagger2/commit/ab65c4a48253c34f8a88221a53dc97bf5e6e8d29));
184− * Fix `Operation` `FromJSON` instance to allow missing `tags` and `parameters` properties.
185−
186−1.2.1
187−---
188−
189−* Minor changes:
190− * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.
191−
192−* Fixes:
193− * Fix build for GHC 8.0-rc1.
194−
195−1.2
196−---
197−* Minor changes (see [#36](https://github.com/GetShopTV/swagger2/pull/36)):
198− * Change default `ToSchema` instance for unit data types (i.e. types with one nullable constructor like `data Unit = Unit`):
199− now these types are treated like sum types with only one alternative;
200− * Add generic `ToParamSchema` instance for unit data types;
201− * Add `items: []` to schema for `()` (making it a valid schema).
202−
203−* Fixes:
204− * Do not omit `items: []` from `Schema` JSON;
205− * Do not generate unused definitions for nested `newtype`s (see [#38](https://github.com/GetShopTV/swagger2/pull/38)).
206−
207−1.1.1
208−---
209−* Fixes:
210− * `CollectionFormat Param` -> `CollectionFormat ParamOtherSchema`;
211− this change was necessary after putting `CollectionFormat` to `SwaggerItems`.
212−
213−1.1
214−---
215−* Major changes:
216− * Put `CollectionFormat` in one place (see [`3cc860d`](https://github.com/GetShopTV/swagger2/commit/3cc860dd3f002ab984f4d0e4ce1d1799f985832e)).
217−
218−* Minor changes:
219− * Use Swagger formats for `Int32`, `Int64`, `Float`, `Double`, `Day` and `ZonedTime` (see [#32](https://github.com/GetShopTV/swagger2/pull/32));
220− * Export `HeaderName`, `TagName`, `HttpStatusCode` type synonyms;
221− * Add `ToParamSchema` instances for `[a]`, `Set a` and `HashSet a`;
222− * Add `Monoid` instances for `Header` and `Example`.
223−
224−* Fixes:
225− * Use overwrite strategy for `HashMap` `SwaggerMonoid` instances by default.
226−
227−1.0
228−---
229−* Major changes:
230− * Add `Data` and `Typeable` instances for `Data.Swagger` types;
231− * Merge `ParamType`/`ItemsType`/`SchemaType` into `SwaggerType` GADT;
232− * Merge collection format types into `CollectionFormat` GADT;
233− * Introduce `SwaggerItems` GADT, replacing `Items` and `SchemaItems` in `ParamSchema` (see [#24](https://github.com/GetShopTV/swagger2/pull/24));
234− * Move type, format and items fields to `ParamSchema` (former `SchemaComon`);
235− * Prepend reference path automatically (see [commit 49d1fad](https://github.com/GetShopTV/swagger2/commit/49d1fadd2100644e70c442667180d0d73e107a5f))
236− and thus remove `"#/definitions/"` from user code, leaving much clearer `Reference "Name"`;
237− * Change `Data.Swagger.Schema` (see [#19](https://github.com/GetShopTV/swagger2/pull/19)):
238− * Change the only method of `ToSchema` to `declareNamedSchema` which should produce a `NamedSchema`
239− along with a list of schema definitions used to produce it;
240− * Add `declareSchema`, `declareSchemaRef`;
241− * Replace `genericTo*` helpers with `genericDeclare*` helpers;
242− * Add `paramSchemaTo[Named]Schema` helpers to facilitate code reuse for primitive schemas;
243− * Add helpers for inlining `Schema` references dynamically (see [#23](https://github.com/GetShopTV/swagger2/pull/23));
244− * Add `ToParamSchema` class (see [#17](https://github.com/GetShopTV/swagger2/pull/17)) with
245− * generic default implementation and
246− * instances for some base types compliant with `http-api-data` instances;
247− * Add `Data.Swagger.Declare` module with
248− * `DeclareT` monad transformer;
249− * `MonadDeclare` type class;
250− * various helpers;
251− * Rename parameter-related types:
252− * `Parameter` -> `Param`;
253− * `ParameterSchema` -> `ParamAnySchema`;
254− * `ParameterOtherSchema` -> `ParamOtherSchema`;
255− * `ParameterLocation` -> `ParamLocation`;
256− * `SchemaCommon` -> `ParamSchema`;
257− * `parameter*` fields renamed to `param*` fields;
258− * `schemaCommon*` fields renamed to `paramSchema*` fields;
259− * `HasSchemaCommon` -> `HasParamSchema`.
260−
261−* Minor changes:
262− * Replace TH-generated JSON instances with `Generic`-based (see [#25](https://github.com/GetShopTV/swagger2/pull/25));
263− * Drop `template-haskell` dependency;
264− * Omit empty array/object properties from `toJSON` output ([#22](https://github.com/GetShopTV/swagger2/pull/22));
265− * Remove `minLength` property from schemas for `time` types;
266− * Move `SchemaOptions` to `Data.Swagger.SchemaOptions`;
267− * Remove `useReferences` from `SchemaOptions` (see [#23](https://github.com/GetShopTV/swagger2/pull/23));
268− * Place all internal submodules under `Data.Swagger.Internal`;
269− * Better documentation (see [#26](https://github.com/GetShopTV/swagger2/pull/26)).
270−
271−0.4.1
272−---
273−* Fixes:
274− * Use `PackageImports` for `Data.HashSet` to avoid test failure on stackage (see [#15](https://github.com/GetShopTV/swagger2/issues/15));
275− * Add an upper version bound for `aeson` due to `aeson-0.10.0.0` bug (see [bos/aeson#293](https://github.com/bos/aeson/issues/293));
276− * Switch to Cabal-based multi GHC Travis config.
277−
278−0.4
279−---
280−* Remove `Swagger`/`swagger` prefixes;
281−* Add `ToSchema` type class with default generic implementation;
282−* Add configurable generic `ToSchema` helpers;
283−* Add `doctest` test suite;
284−* Fixes:
285− * Fix `HasSchemaCommon` instance for `Schema`;
286− * Change `minimum`, `maximum` and `multipleOf` properties to be any number,
287− not necessarily an integer;
288− * Fix all warnings.
289−
290−0.3
291−---
292−* Fixes:
293− * Fix `SwaggerMonoid Text` instance;
294− * Wrap `Bool` in `Maybe` everywhere;
295− * These changes make all `Data.Swagger` `Monoid` instances obey monoid laws
296− (previously right identity law was broken by some instances).
297−
298−0.2
299−---
300−* Add `Data.Swagger.Lens`;
301−* Support references;
302−* Fixes:
303− * Fix `FromJSON SwaggerHost` instance;
304− * Add missing `Maybe`s for field types;
305− * Decode petstore `swagger.json` successfully.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
README.md−37
@@ -1,39 +1,2 @@
11# swagger2
2−
3−[![Join the chat at https://gitter.im/haskell-swagger2/Lobby](https://badges.gitter.im/haskell-swagger2/Lobby.svg)](https://gitter.im/haskell-swagger2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
4−
5−[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
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)
9−
102Swagger 2.0 data model.
11−
12−The original Swagger 2.0 specification is available at http://swagger.io/specification/.
13−
14−## Usage
15−
16−This library is intended to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
17−
18−Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
19−
20−Some examples can be found in [`examples/` directory](/examples).
21−
22−## Trying out
23−
24−All generated swagger specifications can be interactively viewed on [Swagger Editor](http://editor.swagger.io/).
25−
26−Ready-to-use specification can be served as JSON and interactive API documentation
27−can be displayed using [Swagger UI](https://github.com/swagger-api/swagger-ui).
28−
29−Many Swagger tools, including server and client code generation for many languages, can be found on
30−[Swagger's Tools and Integrations page](http://swagger.io/open-source-integrations/).
31−
32−## Contributing
33−
34−We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.
35−
36−Please report bugs via the [github issue tracker](https://github.com/GetShopTV/swagger2/issues).
37−
38−*GetShopTV Team*
39−
Setup.hs−31
@@ -1,33 +1,2 @@
1−{-# LANGUAGE CPP #-}
2−{-# OPTIONS_GHC -Wall #-}
3−module Main (main) where
4−
5−#ifndef MIN_VERSION_cabal_doctest
6−#define MIN_VERSION_cabal_doctest(x,y,z) 0
7−#endif
8−
9−#if MIN_VERSION_cabal_doctest(1,0,0)
10−
11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )
12−main :: IO ()
13−main = defaultMainWithDoctests "doctests"
14−
15−#else
16−
17−#ifdef MIN_VERSION_Cabal
18−-- If the macro is defined, we have new cabal-install,
19−-- but for some reason we don't have cabal-doctest in package-db
20−--
21−-- Probably we are running cabal sdist, when otherwise using new-build
22−-- workflow
23−#warning You are configuring this package without cabal-doctest installed. \
24− The doctests test-suite will not work as a result. \
25− To fix this, install cabal-doctest before configuring.
26−#endif
27−
281import Distribution.Simple
29−
30−main :: IO ()
312main = defaultMain
32−
33−#endif
cabal.projectdeleted−2
@@ -1,2 +0,0 @@
1−packages: .
2−tests: true
examples/hackage.hsdeleted−86
@@ -1,86 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DeriveAnyClass #-}
3−{-# LANGUAGE OverloadedLists #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−module Main where
6−
7−import Control.Lens
8−import Data.Aeson
9−import Data.Proxy
10−import Data.Text (Text)
11−import GHC.Generics
12−
13−import Data.Swagger
14−import Data.Swagger.Declare
15−import Data.Swagger.Lens
16−import Data.Swagger.Operation
17−
18−type Username = Text
19−
20−data UserSummary = UserSummary
21− { summaryUsername :: Username
22− , summaryUserid :: Int
23− } deriving (Generic)
24−
25−instance ToSchema UserSummary where
26− declareNamedSchema _ = do
27− usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
28− useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
29− return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ ?~ SwaggerObject
31− & properties .~
32− [ ("summaryUsername", usernameSchema )
33− , ("summaryUserid" , useridSchema )
34− ]
35− & required .~ [ "summaryUsername"
36− , "summaryUserid" ]
37−
38−
39−type Group = Text
40−
41−data UserDetailed = UserDetailed
42− { username :: Username
43− , userid :: Int
44− , groups :: [Group]
45− } deriving (Generic, ToSchema)
46−
47−newtype Package = Package { packageName :: Text }
48− deriving (Generic, ToSchema)
49−
50−hackageSwagger :: Swagger
51−hackageSwagger = spec & definitions .~ defs
52− where
53− (defs, spec) = runDeclare declareHackageSwagger mempty
54−
55−declareHackageSwagger :: Declare (Definitions Schema) Swagger
56−declareHackageSwagger = do
57− -- param schemas
58− let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)
59−
60− -- responses
61− userSummaryResponse <- declareResponse (Proxy :: Proxy UserSummary)
62− userDetailedResponse <- declareResponse (Proxy :: Proxy UserDetailed)
63− packagesResponse <- declareResponse (Proxy :: Proxy [Package])
64−
65− return $ mempty
66− & paths .~
67− [ ("/users", mempty & get ?~ (mempty
68− & produces ?~ MimeList ["application/json"]
69− & at 200 ?~ Inline userSummaryResponse))
70− , ("/user/{username}", mempty & get ?~ (mempty
71− & produces ?~ MimeList ["application/json"]
72− & parameters .~ [ Inline $ mempty
73− & name .~ "username"
74− & required ?~ True
75− & schema .~ ParamOther (mempty
76− & in_ .~ ParamPath
77− & paramSchema .~ usernameParamSchema) ]
78− & at 200 ?~ Inline userDetailedResponse))
79− , ("/packages", mempty & get ?~ (mempty
80− & produces ?~ MimeList ["application/json"]
81− & at 200 ?~ Inline packagesResponse))
82− ]
83−
84−main :: IO ()
85−main = putStrLn . read . show . encode $ hackageSwagger
86−
hackage-docs.shdeleted−78
@@ -1,78 +0,0 @@
1−#!/bin/bash
2−set -e
3−
4−# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5−
6−if [ "$#" -ne 1 ]; then
7− echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8− exit 1
9−fi
10−
11−user=$1
12−
13−cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14−if [ ! -f "$cabal_file" ]; then
15− echo "Run this script in the top-level package directory"
16− exit 1
17−fi
18−
19−pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20−ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21−
22−if [ -z "$pkg" ]; then
23− echo "Unable to determine package name"
24− exit 1
25−fi
26−
27−if [ -z "$ver" ]; then
28− echo "Unable to determine package version"
29− exit 1
30−fi
31−
32−echo "Detected package: $pkg-$ver"
33−
34−dir=$(mktemp -d build-docs.XXXXXX)
35−trap 'rm -r "$dir"' EXIT
36−
37−export PATH=$(stack path --bin-path)
38−
39−ghc --version
40−cabal --version
41−stack --version
42−
43−if haddock --hyperlinked-source >/dev/null
44−then
45− echo "Using fancy hyperlinked source"
46− HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47−else
48− echo "Using boring hyperlinked source"
49− HYPERLINK_FLAG="--hyperlink-source"
50−fi
51−
52−# Cabal dist in temporary location
53−builddir=$dir/dist
54−
55−# Build dependencies haddocks with stack, so we get links
56−stack haddock --only-dependencies
57−
58−# Configure using stack databases
59−snapshotpkgdb=$(stack path --snapshot-pkg-db)
60−localpkgdb=$(stack path --local-pkg-db)
61−cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62−
63−# Build Hadckage compatible docs
64−cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65−
66−# Copy into right directory
67−cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68−
69−# Tar and gzip
70−tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71−
72−# Upload
73−curl -X PUT \
74− -H 'Content-Type: application/x-tar' \
75− -H 'Content-Encoding: gzip' \
76− -u "$user" \
77− --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78− "https://hackage.haskell.org/package/$pkg-$ver/docs"
include/overlapping-compat.hdeleted−8
@@ -1,8 +0,0 @@
1−#if __GLASGOW_HASKELL__ >= 710
2−#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3−#define OVERLAPPING_ {-# OVERLAPPING #-}
4−#else
5−{-# LANGUAGE OverlappingInstances #-}
6−#define OVERLAPPABLE_
7−#define OVERLAPPING_
8−#endif
src/Data/Swagger.hs−345
@@ -1,350 +1,5 @@
1−{-# LANGUAGE CPP #-}
2−-- |
3−-- Module: Data.Swagger
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7−-- Swagger™ is a project used to describe and document RESTful APIs.
8−--
9−-- The Swagger specification defines a set of files required to describe such an API.
10−-- These files can then be used by the Swagger-UI project to display the API
11−-- and Swagger-Codegen to generate clients in various languages.
12−-- Additional utilities can also take advantage of the resulting files, such as testing tools.
131module Data.Swagger (
14− -- * How to use this library
15− -- $howto
16−
17− -- ** @'Monoid'@ instances
18− -- $monoids
19−
20− -- ** Lenses and prisms
21− -- $lens
22−
23− -- ** Schema specification
24− -- $schema
25−
26− -- ** Manipulation
27− -- $manipulation
28−
29− -- ** Validation
30− -- $validation
31−
32− -- * Re-exports
33− module Data.Swagger.Lens,
34− module Data.Swagger.Optics,
35− module Data.Swagger.Operation,
36− module Data.Swagger.ParamSchema,
37− module Data.Swagger.Schema,
38− module Data.Swagger.Schema.Validation,
39−
40− -- * Swagger specification
41− Swagger(..),
42− Host(..),
43− Scheme(..),
44−
45− -- ** Info types
46− Info(..),
47− Contact(..),
48− License(..),
49−
50− -- ** PathItem
51− PathItem(..),
52−
53− -- ** Operations
54− Operation(..),
55− Tag(..),
56− TagName,
57−
58− -- ** Types and formats
59− SwaggerType(..),
60− Format,
61− Definitions,
62− CollectionFormat(..),
63−
64− -- ** Parameters
65− Param(..),
66− ParamAnySchema(..),
67− ParamOtherSchema(..),
68− ParamLocation(..),
69− ParamName,
70− Header(..),
71− HeaderName,
72− Example(..),
73−
74− -- ** Schemas
75− ParamSchema(..),
76− Schema(..),
77− NamedSchema(..),
78− SwaggerItems(..),
79− Xml(..),
80− Pattern,
81− AdditionalProperties(..),
82−
83− -- ** Responses
84− Responses(..),
85− Response(..),
86− HttpStatusCode,
87−
88− -- ** Security
89− SecurityScheme(..),
90− SecuritySchemeType(..),
91− SecurityRequirement(..),
92− SecurityDefinitions(..),
93−
94− -- *** API key
95− ApiKeyParams(..),
96− ApiKeyLocation(..),
97−
98− -- *** OAuth2
99− OAuth2Params(..),
100− OAuth2Flow(..),
101− AuthorizationURL,
102− TokenURL,
103−
104− -- ** External documentation
105− ExternalDocs(..),
106−
107− -- ** References
108− Reference(..),
109− Referenced(..),
110−
111− -- ** Miscellaneous
112− MimeList(..),
113− URL(..),
1142) where
1153
116−import Data.Swagger.Lens
117−import Data.Swagger.Optics ()
118−import Data.Swagger.Operation
119−import Data.Swagger.ParamSchema
120−import Data.Swagger.Schema
121−import Data.Swagger.Schema.Validation
122−
1234import Data.Swagger.Internal
1245
125−-- $setup
126−-- >>> import Control.Lens
127−-- >>> import Data.Aeson
128−-- >>> import Data.Monoid
129−-- >>> import Data.Proxy
130−-- >>> import GHC.Generics
131−-- >>> :set -XDeriveGeneric
132−-- >>> :set -XOverloadedStrings
133−-- >>> :set -XOverloadedLists
134−-- >>> :set -fno-warn-missing-methods
135−
136−-- $howto
137−--
138−-- This section explains how to use this library to work with Swagger specification.
139−
140−-- $monoids
141−--
142−-- Virtually all types representing Swagger specification have @'Monoid'@ instances.
143−-- The @'Monoid'@ type class provides two methods — @'mempty'@ and @'mappend'@.
144−--
145−-- In this library you can use @'mempty'@ for a default/empty value. For instance:
146−--
147−-- >>> encode (mempty :: Swagger)
148−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}"
149−--
150−-- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty.
151−-- That is because these properties are actually required ones.
152−--
153−-- You /should/ always override the default (empty) value for these properties,
154−-- although it is not strictly necessary:
155−--
156−-- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" }
157−-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"
158−--
159−-- You can merge two values using @'mappend'@ or its infix version @('<>')@:
160−--
161−-- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" }
162−-- "{\"version\":\"1.0\",\"title\":\"Todo API\"}"
163−--
164−-- This can be useful for combining specifications of endpoints into a whole API specification:
165−--
166−-- @
167−-- \-\- /account subAPI specification
168−-- accountAPI :: Swagger
169−--
170−-- \-\- /task subAPI specification
171−-- taskAPI :: Swagger
172−--
173−-- \-\- while API specification is just a combination
174−-- \-\- of subAPIs' specifications
175−-- api :: Swagger
176−-- api = accountAPI <> taskAPI
177−-- @
178−
179−-- $lens
180−--
181−-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182−--
183−-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
184−-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
185−-- make it fairly simple to construct/modify any part of the specification:
186−--
187−-- >>> :{
188−-- encode $ (mempty :: Swagger)
189−-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
190−-- & paths .~
191−-- [ ("/user", mempty & get ?~ (mempty
192−-- & produces ?~ MimeList ["application/json"]
193−-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
194−-- & at 404 ?~ "User info not found")) ]
195−-- :}
196−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
197−--
198−-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
199−-- which produces @application/json@ output. It should respond with code @200@ and body specified
200−-- by schema @User@ which is defined in @'definitions'@ property of swagger specification.
201−-- Alternatively it may respond with code @404@ meaning that user info is not found.
202−--
203−-- For convenience, @swagger2@ uses /classy field lenses/. It means that
204−-- field accessor names can be overloaded for different types. One such
205−-- common field is @'description'@. Many components of a Swagger specification
206−-- can have descriptions, and you can use the same name for them:
207−--
208−-- >>> encode $ (mempty :: Response) & description .~ "No content"
209−-- "{\"description\":\"No content\"}"
210−-- >>> :{
211−-- encode $ (mempty :: Schema)
212−-- & type_ ?~ SwaggerBoolean
213−-- & description ?~ "To be or not to be"
214−-- :}
215−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
216−--
217−-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
218−-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
219−-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
220−--
221−-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
222−-- "{\"type\":\"number\"}"
223−--
224−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
225−-- have direct access to it via @'at' code@. Example:
226−--
227−-- >>> :{
228−-- encode $ (mempty :: Operation)
229−-- & at 404 ?~ "Not found"
230−-- :}
231−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
232−--
233−-- You might've noticed that @'type_'@ has an extra underscore in its name
234−-- compared to, say, @'description'@ field accessor.
235−-- This is because @type@ is a keyword in Haskell.
236−-- A few other field accessors are modified in this way:
237−--
238−-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);
239−-- - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);
240−-- - @'enum_'@ (as conflicting with @Control.Lens@).
241−
242−-- $schema
243−--
244−-- @'ParamSchema'@ and @'Schema'@ are the two core types for data model specification.
245−--
246−-- @'ParamSchema' t@ specifies all the common properties, available for every data schema.
247−-- The @t@ parameter imposes some restrictions on @type@ and @items@ properties (see @'SwaggerType'@ and @'SwaggerItems'@).
248−--
249−-- @'Schema'@ is used for request and response bodies and allows specifying objects
250−-- with properties in addition to what @'ParamSchema'@ provides.
251−--
252−-- In most cases you will have a Haskell data type for which you would like to
253−-- define a corresponding schema. To facilitate this use case
254−-- @swagger2@ provides two classes for schema encoding.
255−-- Both these classes provide means to encode /types/ as Swagger /schemas/.
256−--
257−-- @'ToParamSchema'@ is intended to be used for primitive API endpoint parameters,
258−-- such as query parameters, headers and URL path pieces.
259−-- Its corresponding value-encoding class is @'ToHttpApiData'@ (from @http-api-data@ package).
260−--
261−-- @'ToSchema'@ is used for request and response bodies and mostly differ from
262−-- primitive parameters by allowing objects/mappings in addition to primitive types and arrays.
263−-- Its corresponding value-encoding class is @'ToJSON'@ (from @aeson@ package).
264−--
265−-- While lenses and prisms make it easy to define schemas, it might be that you don't need to:
266−-- @'ToSchema'@ and @'ToParamSchema'@ classes both have default @'Generic'@-based implementations!
267−--
268−-- @'ToSchema'@ default implementation is also aligned with @'ToJSON'@ default implementation with
269−-- the only difference being for sum encoding. @'ToJSON'@ defaults sum encoding to @'defaultTaggedObject'@,
270−-- while @'ToSchema'@ defaults to something which corresponds to @'ObjectWithSingleField'@. This is due to
271−-- @'defaultTaggedObject'@ behavior being hard to specify in Swagger.
272−--
273−-- Here's an example showing @'ToJSON'@–@'ToSchema'@ correspondance:
274−--
275−-- >>> data Person = Person { name :: String, age :: Integer } deriving Generic
276−-- >>> instance ToJSON Person
277−-- >>> instance ToSchema Person
278−-- >>> encode (Person "David" 28)
279−-- "{\"age\":28,\"name\":\"David\"}"
280−-- >>> encode $ toSchema (Proxy :: Proxy Person)
281−-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
282−--
283−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
284−-- schema for basic enums like
285−--
286−-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
287−-- >>> instance ToSchema SampleEnum
288−-- >>> instance ToJSON SampleEnum
289−--
290−-- and for sum types that have constructors with values
291−--
292−-- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic
293−-- >>> instance ToSchema SampleSumType
294−-- >>> instance ToJSON SampleSumType
295−--
296−-- we can not derive a valid schema for a mix of the above. The following will result in a type error
297−--
298−#if __GLASGOW_HASKELL__ < 800
299−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
300−-- >>> instance ToSchema BadMixedType
301−-- ...
302−-- ... error:
303−-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType
304−-- ... BadMixedType)
305−-- ... arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’
306−-- ... • In the expression:
307−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
308−-- ... In an equation for ‘declareNamedSchema’:
309−-- ... declareNamedSchema
310−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
311−-- ... In the instance declaration for ‘ToSchema BadMixedType’
312−#else
313−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
314−-- >>> instance ToSchema BadMixedType
315−-- ...
316−-- ... error:
317−-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType
318−-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).
319−-- ... Swagger does not have a good representation for these types.
320−-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema
321−-- ... that matches aeson's Generic-based toJSON,
322−-- ... but that's not supported by some Swagger tools.
323−-- ... • In the expression:
324−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
325−-- ... In an equation for ‘declareNamedSchema’:
326−-- ... declareNamedSchema
327−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
328−-- ... In the instance declaration for ‘ToSchema BadMixedType’
329−#endif
330−--
331−-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':
332−--
333−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
334−-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
335−-- >>> instance ToJSON BadMixedType
336−--
337−
338−-- $manipulation
339−-- Sometimes you have to work with an imported or generated @'Swagger'@.
340−-- For instance, <servant-swagger http://hackage.haskell.org/package/servant-swagger> generates basic @'Swagger'@
341−-- for a type-level servant API.
342−--
343−-- Lenses and prisms can be used to manipulate such specification to add additional information, tags, extra responses, etc.
344−-- To facilitate common needs, @"Data.Swagger.Operation"@ module provides useful helpers.
345−
346−-- $validation
347−-- While @'ToParamSchema'@ and @'ToSchema'@ provide means to easily obtain schemas for Haskell types,
348−-- there is no static mechanism to ensure those instances correspond to the @'ToHttpApiData'@ or @'ToJSON'@ instances.
349−--
350−-- @"Data.Swagger.Schema.Validation"@ addresses @'ToJSON'@/@'ToSchema'@ validation.
src/Data/Swagger/Declare.hsdeleted−199
@@ -1,199 +0,0 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE UndecidableInstances #-}
6−-- |
7−-- Module: Data.Swagger.Declare
8−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
9−-- Stability: experimental
10−--
11−-- Declare monad transformer and associated functions.
12−module Data.Swagger.Declare where
13−
14−import Prelude ()
15−import Prelude.Compat
16−
17−import Control.Monad
18−import Control.Monad.Cont (ContT)
19−import Control.Monad.List (ListT)
20−import Control.Monad.Reader (ReaderT)
21−import Control.Monad.Trans
22−import Control.Monad.Trans.Except (ExceptT)
23−import Control.Monad.Trans.Identity (IdentityT)
24−import Control.Monad.Trans.Maybe (MaybeT)
25−import Control.Monad.Trans.State.Lazy as Lazy
26−import Control.Monad.Trans.State.Strict as Strict
27−import Control.Monad.Trans.RWS.Lazy as Lazy
28−import Control.Monad.Trans.RWS.Strict as Strict
29−import Control.Monad.Trans.Writer.Lazy as Lazy
30−import Control.Monad.Trans.Writer.Strict as Strict
31−import Data.Functor.Identity
32−
33−-- | A declare monad transformer parametrized by:
34−--
35−-- * @d@ — the output to accumulate (declarations);
36−--
37−-- * @m@ — the inner monad.
38−--
39−-- This monad transformer is similar to both state and writer monad transformers.
40−-- Thus it can be seen as
41−--
42−-- * a restricted append-only version of a state monad transformer or
43−--
44−-- * a writer monad transformer with the extra ability to read all previous output.
45−newtype DeclareT d m a = DeclareT { runDeclareT :: d -> m (d, a) }
46− deriving (Functor)
47−
48−instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
49− pure x = DeclareT (\_ -> pure (mempty, x))
50− DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
51− ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
53− return (mappend d' d'', f x)
54−
55−instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
56− return x = DeclareT (\_ -> pure (mempty, x))
57− DeclareT dx >>= f = DeclareT $ \d -> do
58− ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
60− return (mappend d' d'', y)
61−
62−instance Monoid d => MonadTrans (DeclareT d) where
63− lift m = DeclareT (\_ -> (,) mempty `liftM` m)
64−
65−-- |
66−-- Definitions of @declare@ and @look@ must satisfy the following laws:
67−--
68−-- [/monoid homomorphism (mempty)/]
69−-- @'declare' mempty == return ()@
70−--
71−-- [/monoid homomorphism (mappend)/]
72−-- @'declare' x >> 'declare' y == 'declare' (x <> y)@
73−-- for every @x@, @y@
74−--
75−-- [/@declare@-@look@/]
76−-- @'declare' x >> 'look' == 'fmap' (<> x) 'look' <* 'declare' x@
77−-- for every @x@
78−--
79−-- [/@look@ as left identity/]
80−-- @'look' >> m == m@
81−-- for every @m@
82−class (Applicative m, Monad m) => MonadDeclare d m | m -> d where
83− -- | @'declare' x@ is an action that produces the output @x@.
84− declare :: d -> m ()
85− -- | @'look'@ is an action that returns all the output so far.
86− look :: m d
87−
88−instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) where
89− declare d = DeclareT (\_ -> return (d, ()))
90− look = DeclareT (\d -> return (mempty, d))
91−
92−-- | Lift a computation from the simple Declare monad.
93−liftDeclare :: MonadDeclare d m => Declare d a -> m a
94−liftDeclare da = do
95− (d', a) <- looks (runDeclare da)
96− declare d'
97− pure a
98−
99−-- | Retrieve a function of all the output so far.
100−looks :: MonadDeclare d m => (d -> a) -> m a
101−looks f = f <$> look
102−
103−-- | Evaluate @'DeclareT' d m a@ computation,
104−-- ignoring new output @d@.
105−evalDeclareT :: Monad m => DeclareT d m a -> d -> m a
106−evalDeclareT (DeclareT f) d = snd `liftM` f d
107−
108−-- | Execute @'DeclateT' d m a@ computation,
109−-- ignoring result and only producing new output @d@.
110−execDeclareT :: Monad m => DeclareT d m a -> d -> m d
111−execDeclareT (DeclareT f) d = fst `liftM` f d
112−
113−-- | Evaluate @'DeclareT' d m a@ computation,
114−-- starting with empty output history.
115−undeclareT :: (Monad m, Monoid d) => DeclareT d m a -> m a
116−undeclareT = flip evalDeclareT mempty
117−
118−-- | A declare monad parametrized by @d@ — the output to accumulate (declarations).
119−--
120−-- This monad is similar to both state and writer monads.
121−-- Thus it can be seen as
122−--
123−-- * a restricted append-only version of a state monad or
124−--
125−-- * a writer monad with the extra ability to read all previous output.
126−type Declare d = DeclareT d Identity
127−
128−-- | Run @'Declare' d a@ computation with output history @d@,
129−-- producing result @a@ and new output @d@.
130−runDeclare :: Declare d a -> d -> (d, a)
131−runDeclare m = runIdentity . runDeclareT m
132−
133−-- | Evaluate @'Declare' d a@ computation, ignoring output @d@.
134−evalDeclare :: Declare d a -> d -> a
135−evalDeclare m = runIdentity . evalDeclareT m
136−
137−-- | Execute @'Declate' d a@ computation, ignoring result and only
138−-- producing output @d@.
139−execDeclare :: Declare d a -> d -> d
140−execDeclare m = runIdentity . execDeclareT m
141−
142−-- | Evaluate @'DeclareT' d m a@ computation,
143−-- starting with empty output history.
144−undeclare :: Monoid d => Declare d a -> a
145−undeclare = runIdentity . undeclareT
146−
147−-- ---------------------------------------------------------------------------
148−-- Instances for other mtl transformers
149−--
150−-- All of these instances need UndecidableInstances,
151−-- because they do not satisfy the coverage condition.
152−
153−instance MonadDeclare d m => MonadDeclare d (ContT r m) where
154− declare = lift . declare
155− look = lift look
156−
157−instance MonadDeclare d m => MonadDeclare d (ExceptT e m) where
158− declare = lift . declare
159− look = lift look
160−
161−instance MonadDeclare d m => MonadDeclare d (IdentityT m) where
162− declare = lift . declare
163− look = lift look
164−
165−instance MonadDeclare d m => MonadDeclare d (ListT m) where
166− declare = lift . declare
167− look = lift look
168−
169−instance MonadDeclare d m => MonadDeclare d (MaybeT m) where
170− declare = lift . declare
171− look = lift look
172−
173−instance MonadDeclare d m => MonadDeclare d (ReaderT r m) where
174− declare = lift . declare
175− look = lift look
176−
177−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.RWST r w s m) where
178− declare = lift . declare
179− look = lift look
180−
181−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.RWST r w s m) where
182− declare = lift . declare
183− look = lift look
184−
185−instance MonadDeclare d m => MonadDeclare d (Lazy.StateT s m) where
186− declare = lift . declare
187− look = lift look
188−
189−instance MonadDeclare d m => MonadDeclare d (Strict.StateT s m) where
190− declare = lift . declare
191− look = lift look
192−
193−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.WriterT w m) where
194− declare = lift . declare
195− look = lift look
196−
197−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.WriterT w m) where
198− declare = lift . declare
199− look = lift look
src/Data/Swagger/Internal.hs+335−1138
@@ -1,636 +1,450 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DeriveFunctor #-}
51{-# LANGUAGE DeriveGeneric #-}
6−{-# LANGUAGE DeriveTraversable #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE FlexibleInstances #-}
9−{-# LANGUAGE GADTs #-}
10−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11−{-# LANGUAGE OverloadedStrings #-}
12−{-# LANGUAGE RecordWildCards #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TemplateHaskell #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ <710
19−{-# LANGUAGE PolyKinds #-}
20−#endif
21−#include "overlapping-compat.h"
222module Data.Swagger.Internal where
233
24−import Prelude ()
25−import Prelude.Compat
26−
27−import Control.Lens ((&), (.~), (?~))
28−import Control.Applicative
29−import Data.Aeson
30−import qualified Data.Aeson.Types as JSON
31−import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32−import Data.Hashable (Hashable)
33−import qualified Data.HashMap.Strict as HashMap
34−import Data.HashSet.InsOrd (InsOrdHashSet)
35−import Data.Map (Map)
36−import qualified Data.Map as Map
37−import Data.Monoid (Monoid (..))
38−import Data.Semigroup.Compat (Semigroup (..))
39−import Data.Scientific (Scientific)
40−import Data.String (IsString(..))
4+import qualified Data.Aeson as JSON
5+import Data.HashMap.Strict (HashMap)
416import Data.Text (Text)
42−import qualified Data.Text as Text
7+import Data.Hashable (Hashable)
438import GHC.Generics (Generic)
44−import Network.Socket (HostName, PortNumber)
9+import Network (HostName, PortNumber)
4510import Network.HTTP.Media (MediaType)
46−import Text.Read (readMaybe)
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)
60−import Data.Swagger.Internal.Utils
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
11+import Network.URL (URL)
7512
7613-- | This is the root document object for the API specification.
7714data Swagger = Swagger
7815 { -- | Provides metadata about the API.
7916 -- The metadata can be used by the clients if needed.
80− _swaggerInfo :: Info
17+ swaggerInfo :: SwaggerInfo
8118
8219 -- | The host (name or ip) serving the API. It MAY include a port.
8320 -- If the host is not included, the host serving the documentation is to be used (including the port).
84− , _swaggerHost :: Maybe Host
21+ , swaggerHost :: Maybe SwaggerHost
8522
8623 -- | The base path on which the API is served, which is relative to the host.
8724 -- If it is not included, the API is served directly under the host.
8825 -- The value MUST start with a leading slash (/).
89− , _swaggerBasePath :: Maybe FilePath
26+ , swaggerBasePath :: Maybe FilePath
9027
9128 -- | The transfer protocol of the API.
9229 -- If the schemes is not included, the default scheme to be used is the one used to access the Swagger definition itself.
93− , _swaggerSchemes :: Maybe [Scheme]
30+ , swaggerSchemes :: Maybe [SwaggerScheme]
9431
9532 -- | A list of MIME types the APIs can consume.
9633 -- This is global to all APIs but can be overridden on specific API calls.
97− , _swaggerConsumes :: MimeList
34+ , swaggerConsumes :: [MediaType]
9835
9936 -- | A list of MIME types the APIs can produce.
100− -- This is global to all APIs but can be overridden on specific API calls.
101− , _swaggerProduces :: MimeList
37+ -- This is global to all APIs but can be overridden on specific API calls.
38+ , swaggerProduces :: [MediaType]
10239
10340 -- | The available paths and operations for the API.
104− -- Holds the relative paths to the individual endpoints.
105− -- The path is appended to the @'basePath'@ in order to construct the full URL.
106− , _swaggerPaths :: InsOrdHashMap FilePath PathItem
41+ , swaggerPaths :: SwaggerPaths
10742
10843 -- | An object to hold data types produced and consumed by operations.
109− , _swaggerDefinitions :: Definitions Schema
44+ , swaggerDefinitions :: HashMap Text SwaggerSchema
11045
11146 -- | An object to hold parameters that can be used across operations.
11247 -- This property does not define global parameters for all operations.
113− , _swaggerParameters :: Definitions Param
48+ , swaggerParameters :: HashMap Text SwaggerParameter
11449
11550 -- | An object to hold responses that can be used across operations.
11651 -- This property does not define global responses for all operations.
117− , _swaggerResponses :: Definitions Response
52+ , swaggerResponses :: HashMap Text SwaggerResponse
11853
11954 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: SecurityDefinitions
55+ , swaggerSecurityDefinitions :: HashMap Text SwaggerSecurityScheme
12156
12257 -- | A declaration of which security schemes are applied for the API as a whole.
12358 -- The list of values describes alternative security schemes that can be used
12459 -- (that is, there is a logical OR between the security requirements).
12560 -- Individual operations can override this definition.
126− , _swaggerSecurity :: [SecurityRequirement]
61+ , swaggerSecurity :: [SwaggerSecurityRequirement]
12762
12863 -- | A list of tags used by the specification with additional metadata.
12964 -- The order of the tags can be used to reflect on their order by the parsing tools.
13065 -- Not all tags that are used by the Operation Object must be declared.
13166 -- The tags that are not declared may be organized randomly or based on the tools' logic.
13267 -- Each tag name in the list MUST be unique.
133− , _swaggerTags :: InsOrdHashSet Tag
68+ , swaggerTags :: [SwaggerTag]
13469
13570 -- | Additional external documentation.
136− , _swaggerExternalDocs :: Maybe ExternalDocs
137− } deriving (Eq, Show, Generic, Data, Typeable)
71+ , swaggerExternalDocs :: SwaggerExternalDocs
72+ } deriving (Show)
13873
13974-- | The object provides metadata about the API.
14075-- The metadata can be used by the clients if needed,
14176-- and can be presented in the Swagger-UI for convenience.
142−data Info = Info
77+data SwaggerInfo = SwaggerInfo
14378 { -- | The title of the application.
144− _infoTitle :: Text
79+ swaggerInfoTitle :: Text
14580
14681 -- | A short description of the application.
14782 -- GFM syntax can be used for rich text representation.
148− , _infoDescription :: Maybe Text
83+ , swaggerInfoDescription :: Maybe Text
14984
15085 -- | The Terms of Service for the API.
151− , _infoTermsOfService :: Maybe Text
86+ , swaggerInfoTermsOfService :: Maybe Text
15287
15388 -- | The contact information for the exposed API.
154− , _infoContact :: Maybe Contact
89+ , swaggerInfoContact :: Maybe SwaggerContact
15590
15691 -- | The license information for the exposed API.
157− , _infoLicense :: Maybe License
92+ , swaggerInfoLicense :: Maybe SwaggerLicense
15893
15994 -- | Provides the version of the application API
16095 -- (not to be confused with the specification version).
161− , _infoVersion :: Text
162− } deriving (Eq, Show, Generic, Data, Typeable)
96+ , swaggerInfoVersion :: Text
97+ } deriving (Show)
16398
16499-- | Contact information for the exposed API.
165−data Contact = Contact
100+data SwaggerContact = SwaggerContact
166101 { -- | The identifying name of the contact person/organization.
167− _contactName :: Maybe Text
102+ swaggerContactName :: Maybe Text
168103
169104 -- | The URL pointing to the contact information.
170− , _contactUrl :: Maybe URL
105+ , swaggerContactURL :: Maybe URL
171106
172107 -- | The email address of the contact person/organization.
173− , _contactEmail :: Maybe Text
174− } deriving (Eq, Show, Generic, Data, Typeable)
108+ , swaggerContactEmail :: Maybe Text
109+ } deriving (Show)
175110
176111-- | License information for the exposed API.
177−data License = License
112+data SwaggerLicense = SwaggerLicense
178113 { -- | The license name used for the API.
179− _licenseName :: Text
114+ swaggerLicenseName :: Text
180115
181116 -- | A URL to the license used for the API.
182− , _licenseUrl :: Maybe URL
183− } deriving (Eq, Show, Generic, Data, Typeable)
184−
185−instance IsString License where
186− fromString s = License (fromString s) Nothing
117+ , swaggerLicenseURL :: Maybe URL
118+ } deriving (Show)
187119
188120-- | The host (name or ip) serving the API. It MAY include a port.
189−data Host = Host
190− { _hostName :: HostName -- ^ Host name.
191− , _hostPort :: Maybe PortNumber -- ^ Optional port.
192− } deriving (Eq, Show, Generic, Typeable)
193−
194−instance IsString Host where
195− fromString s = Host s Nothing
196−
197−hostConstr :: Constr
198−hostConstr = mkConstr hostDataType "Host" [] Prefix
199−
200−hostDataType :: DataType
201−hostDataType = mkDataType "Data.Swagger.Host" [hostConstr]
202−
203−instance Data Host where
204− gunfold k z c = case constrIndex c of
205− 1 -> k (k (z (\name mport -> Host name (fromInteger <$> mport))))
206− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type Host."
207− toConstr (Host _ _) = hostConstr
208− dataTypeOf _ = hostDataType
121+data SwaggerHost = SwaggerHost
122+ { swaggerHostName :: HostName -- ^ Host name.
123+ , swaggerHostPort :: Maybe PortNumber -- ^ Optional port.
124+ } deriving (Show)
209125
210126-- | The transfer protocol of the API.
211−data Scheme
127+data SwaggerScheme
212128 = Http
213129 | Https
214130 | Ws
215131 | Wss
216− deriving (Eq, Show, Generic, Data, Typeable)
132+ deriving (Show)
133+
134+-- | The available paths and operations for the API.
135+data SwaggerPaths = SwaggerPaths
136+ { -- | Holds the relative paths to the individual endpoints.
137+ -- The path is appended to the @'swaggerBasePath'@ in order to construct the full URL.
138+ swaggerPathsMap :: HashMap FilePath SwaggerPathItem
139+ } deriving (Show)
217140
218141-- | Describes the operations available on a single path.
219−-- A @'PathItem'@ may be empty, due to ACL constraints.
142+-- A @'SwaggerPathItem'@ may be empty, due to ACL constraints.
220143-- The path itself is still exposed to the documentation viewer
221144-- but they will not know which operations and parameters are available.
222−data PathItem = PathItem
145+data SwaggerPathItem = SwaggerPathItem
223146 { -- | A definition of a GET operation on this path.
224− _pathItemGet :: Maybe Operation
147+ swaggerPathItemGet :: Maybe SwaggerOperation
225148
226149 -- | A definition of a PUT operation on this path.
227− , _pathItemPut :: Maybe Operation
150+ , swaggerPathItemPut :: Maybe SwaggerOperation
228151
229152 -- | A definition of a POST operation on this path.
230− , _pathItemPost :: Maybe Operation
153+ , swaggerPathItemPost :: Maybe SwaggerOperation
231154
232155 -- | A definition of a DELETE operation on this path.
233− , _pathItemDelete :: Maybe Operation
156+ , swaggerPathItemDelete :: Maybe SwaggerOperation
234157
235158 -- | A definition of a OPTIONS operation on this path.
236− , _pathItemOptions :: Maybe Operation
159+ , swaggerPathItemOptions :: Maybe SwaggerOperation
237160
238161 -- | A definition of a HEAD operation on this path.
239− , _pathItemHead :: Maybe Operation
162+ , swaggerPathItemHead :: Maybe SwaggerOperation
240163
241164 -- | A definition of a PATCH operation on this path.
242− , _pathItemPatch :: Maybe Operation
165+ , swaggerPathItemPatch :: Maybe SwaggerOperation
243166
244167 -- | A list of parameters that are applicable for all the operations described under this path.
245168 -- These parameters can be overridden at the operation level, but cannot be removed there.
246169 -- The list MUST NOT include duplicated parameters.
247170 -- A unique parameter is defined by a combination of a name and location.
248− , _pathItemParameters :: [Referenced Param]
249− } deriving (Eq, Show, Generic, Data, Typeable)
171+ , swaggerPathItemParameters :: [SwaggerParameter]
172+ } deriving (Show)
250173
251174-- | Describes a single API operation on a path.
252−data Operation = Operation
175+data SwaggerOperation = SwaggerOperation
253176 { -- | A list of tags for API documentation control.
254177 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
255− _operationTags :: InsOrdHashSet TagName
178+ swaggerOperationTags :: [Text]
256179
257180 -- | A short summary of what the operation does.
258181 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
259− , _operationSummary :: Maybe Text
182+ , swaggerOperationSummary :: Maybe Text
260183
261184 -- | A verbose explanation of the operation behavior.
262185 -- GFM syntax can be used for rich text representation.
263− , _operationDescription :: Maybe Text
186+ , swaggerOperationDescription :: Maybe Text
264187
265188 -- | Additional external documentation for this operation.
266− , _operationExternalDocs :: Maybe ExternalDocs
189+ , swaggerOperationExternalDocs :: Maybe SwaggerExternalDocs
267190
268191 -- | Unique string used to identify the operation.
269192 -- The id MUST be unique among all operations described in the API.
270193 -- Tools and libraries MAY use the it to uniquely identify an operation,
271194 -- therefore, it is recommended to follow common programming naming conventions.
272− , _operationOperationId :: Maybe Text
195+ , swaggerOperationOperationId :: Maybe Text
273196
274197 -- | A list of MIME types the operation can consume.
275− -- This overrides the @'consumes'@.
198+ -- This overrides the @'swaggerConsumes'@.
276199 -- @Just []@ MAY be used to clear the global definition.
277− , _operationConsumes :: Maybe MimeList
200+ , swaggerOperationConsumes :: Maybe [MediaType]
278201
279202 -- | A list of MIME types the operation can produce.
280− -- This overrides the @'produces'@.
203+ -- This overrides the @'swaggerProduces'@.
281204 -- @Just []@ MAY be used to clear the global definition.
282− , _operationProduces :: Maybe MimeList
205+ , swaggerOperationProduces :: Maybe [MediaType]
283206
284207 -- | A list of parameters that are applicable for this operation.
285− -- If a parameter is already defined at the @'PathItem'@,
208+ -- If a parameter is already defined at the @'SwaggerPathItem'@,
286209 -- the new definition will override it, but can never remove it.
287210 -- The list MUST NOT include duplicated parameters.
288211 -- A unique parameter is defined by a combination of a name and location.
289− , _operationParameters :: [Referenced Param]
212+ , swaggerOperationParameters :: [SwaggerParameter]
290213
291214 -- | The list of possible responses as they are returned from executing this operation.
292− , _operationResponses :: Responses
215+ , swaggerOperationResponses :: SwaggerResponses
293216
294217 -- | The transfer protocol for the operation.
295− -- The value overrides @'schemes'@.
296− , _operationSchemes :: Maybe [Scheme]
218+ -- The value overrides @'swaggerSchemes'@.
219+ , swaggerOperationSchemes :: Maybe [SwaggerScheme]
297220
298221 -- | Declares this operation to be deprecated.
299222 -- Usage of the declared operation should be refrained.
300223 -- Default value is @False@.
301− , _operationDeprecated :: Maybe Bool
224+ , swaggerOperationDeprecated :: Bool
302225
303226 -- | A declaration of which security schemes are applied for this operation.
304227 -- The list of values describes alternative security schemes that can be used
305228 -- (that is, there is a logical OR between the security requirements).
306229 -- This definition overrides any declared top-level security.
307230 -- To remove a top-level security declaration, @Just []@ can be used.
308− , _operationSecurity :: [SecurityRequirement]
309− } deriving (Eq, Show, Generic, Data, Typeable)
310−
311−newtype MimeList = MimeList { getMimeList :: [MediaType] }
312− deriving (Eq, Show, Semigroup, Monoid, Typeable)
313−
314−mimeListConstr :: Constr
315−mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
316−
317−mimeListDataType :: DataType
318−mimeListDataType = mkDataType "Data.Swagger.MimeList" [mimeListConstr]
319−
320−instance Data MimeList where
321− gunfold k z c = case constrIndex c of
322− 1 -> k (z (\xs -> MimeList (map fromString xs)))
323− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type MimeList."
324− toConstr (MimeList _) = mimeListConstr
325− dataTypeOf _ = mimeListDataType
231+ , swaggerOperationSecurity :: [SwaggerSecurityRequirement]
232+ } deriving (Show)
326233
327234-- | Describes a single operation parameter.
328235-- A unique parameter is defined by a combination of a name and location.
329−data Param = Param
236+data SwaggerParameter = SwaggerParameter
330237 { -- | The name of the parameter.
331238 -- Parameter names are case sensitive.
332− _paramName :: Text
239+ swaggerParameterName :: Text
333240
334241 -- | A brief description of the parameter.
335242 -- This could contain examples of use.
336243 -- GFM syntax can be used for rich text representation.
337− , _paramDescription :: Maybe Text
244+ , swaggerParameterDescription :: Maybe Text
338245
339246 -- | Determines whether this parameter is mandatory.
340247 -- If the parameter is in "path", this property is required and its value MUST be true.
341248 -- Otherwise, the property MAY be included and its default value is @False@.
342− , _paramRequired :: Maybe Bool
249+ , swaggerParameterRequired :: Bool
343250
344251 -- | Parameter schema.
345− , _paramSchema :: ParamAnySchema
346− } deriving (Eq, Show, Generic, Data, Typeable)
252+ , swaggerParameterSchema :: SwaggerParameterSchema
253+ } deriving (Show)
347254
348−data ParamAnySchema
349− = ParamBody (Referenced Schema)
350− | ParamOther ParamOtherSchema
351− deriving (Eq, Show, Generic, Data, Typeable)
255+data SwaggerParameterSchema
256+ = SwaggerParameterBody SwaggerSchema
257+ | SwaggerParameterOther SwaggerParameterOtherSchema
258+ deriving (Show)
352259
353−data ParamOtherSchema = ParamOtherSchema
260+data SwaggerParameterOtherSchema = SwaggerParameterOtherSchema
354261 { -- | The location of the parameter.
355− _paramOtherSchemaIn :: ParamLocation
262+ swaggerParameterOtherSchemaIn :: SwaggerParameterLocation
263+
264+ -- | The type of the parameter.
265+ -- Since the parameter is not located at the request body,
266+ -- it is limited to simple types (that is, not an object).
267+ -- If type is @'SwaggerParamFile'@, the @consumes@ MUST be either
268+ -- "multipart/form-data" or " application/x-www-form-urlencoded"
269+ -- and the parameter MUST be in @'SwaggerParameterFormData'@.
270+ , swaggerParameterOtherSchemaType :: SwaggerParameterType
271+
272+ -- | The extending format for the previously mentioned type.
273+ , swaggerParameterOtherSchemaFormat :: Maybe SwaggerFormat
356274
357275 -- | Sets the ability to pass empty-valued parameters.
358− -- This is valid only for either @'ParamQuery'@ or @'ParamFormData'@
276+ -- This is valid only for either @'SwaggerParameterQuery'@ or @'SwaggerParameterFormData'@
359277 -- and allows you to send a parameter with a name only or an empty value.
360278 -- Default value is @False@.
361− , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
362−
363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
364− } deriving (Eq, Show, Generic, Typeable, Data)
365−
366−-- | Items for @'SwaggerArray'@ schemas.
367−--
368−-- @'SwaggerItemsPrimitive'@ should be used only for query params, headers and path pieces.
369−-- The @'CollectionFormat' t@ parameter specifies how elements of an array should be displayed.
370−-- Note that @fmt@ in @'SwaggerItemsPrimitive' fmt schema@ specifies format for elements of type @schema@.
371−-- This is different from the original Swagger's <http://swagger.io/specification/#itemsObject Items Object>.
372−--
373−-- @'SwaggerItemsObject'@ should be used to specify homogenous array @'Schema'@s.
374−--
375−-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
376−data SwaggerItems t where
377− SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
378− SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
379− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
380− deriving (Typeable)
381−
382−deriving instance Eq (SwaggerItems t)
383−deriving instance Show (SwaggerItems t)
384−--deriving instance Typeable (SwaggerItems t)
385−
386−swaggerItemsPrimitiveConstr :: Constr
387−swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
388−
389−swaggerItemsObjectConstr :: Constr
390−swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
391−
392−swaggerItemsArrayConstr :: Constr
393−swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
394−
395−swaggerItemsDataType :: DataType
396−swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
397−
398−-- Note: unfortunately we have to write these Data instances by hand,
399−-- to get better contexts / avoid duplicate name when using standalone deriving
400−
401−instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where
402− -- TODO: define gfoldl
403− gunfold k z c = case constrIndex c of
404− 1 -> k (k (z SwaggerItemsPrimitive))
405− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
406− toConstr _ = swaggerItemsPrimitiveConstr
407− dataTypeOf _ = swaggerItemsDataType
408−
409−-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only
410−instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where
411− -- TODO: define gfoldl
412− gunfold k z c = case constrIndex c of
413− 1 -> k (k (z SwaggerItemsPrimitive))
414− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."
415− toConstr _ = swaggerItemsPrimitiveConstr
416− dataTypeOf _ = swaggerItemsDataType
417−
418−instance Data (SwaggerItems 'SwaggerKindSchema) where
419− gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"
420− gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref
421− gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref
422−
423− gunfold k z c = case constrIndex c of
424− 2 -> k (z SwaggerItemsObject)
425− 3 -> k (z SwaggerItemsArray)
426− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)."
427−
428− toConstr (SwaggerItemsPrimitive _ _) = error "Not supported"
429− toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr
430− toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr
431−
432− dataTypeOf _ = swaggerItemsDataType
433−
434−-- | Type used as a kind to avoid overlapping instances.
435−data SwaggerKind t
436− = SwaggerKindNormal t
437− | SwaggerKindParamOtherSchema
438− | SwaggerKindSchema
439− deriving (Typeable)
440−
441−deriving instance Typeable 'SwaggerKindNormal
442−deriving instance Typeable 'SwaggerKindParamOtherSchema
443−deriving instance Typeable 'SwaggerKindSchema
444−
445−type family SwaggerKindType (k :: SwaggerKind *) :: *
446−type instance SwaggerKindType ('SwaggerKindNormal t) = t
447−type instance SwaggerKindType 'SwaggerKindSchema = Schema
448−type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema
449−
450−data SwaggerType t where
451− SwaggerString :: SwaggerType t
452− SwaggerNumber :: SwaggerType t
453− SwaggerInteger :: SwaggerType t
454− SwaggerBoolean :: SwaggerType t
455− SwaggerArray :: SwaggerType t
456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
457− SwaggerNull :: SwaggerType 'SwaggerKindSchema
458− SwaggerObject :: SwaggerType 'SwaggerKindSchema
459− deriving (Typeable)
460−
461−deriving instance Eq (SwaggerType t)
462−deriving instance Show (SwaggerType t)
463−
464−swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
465−swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
466−
467−swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
468−swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
469−
470−swaggerCommonTypes :: [SwaggerType k]
471−swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
472−
473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
474−swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
475−
476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
477−swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
478−
479−swaggerTypeConstrs :: [Constr]
480−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
481− ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
482−
483−instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
484− gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
485− toConstr = swaggerTypeConstr
486− dataTypeOf = swaggerTypeDataType
487−
488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
489− gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
490− toConstr = swaggerTypeConstr
491− dataTypeOf = swaggerTypeDataType
492−
493−instance Data (SwaggerType 'SwaggerKindSchema) where
494− gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
495− toConstr = swaggerTypeConstr
496− dataTypeOf = swaggerTypeDataType
497−
498−data ParamLocation
279+ , swaggerParameterOtherSchemaAllowEmptyValue :: Bool
280+
281+ -- | __Required if type is @'SwaggerParamArray'@__.
282+ -- Describes the type of items in the array.
283+ , swaggerParameterOtherSchemaItems :: Maybe SwaggerItems
284+
285+ -- | Determines the format of the array if @'SwaggerParamArray'@ is used.
286+ -- Default value is csv.
287+ , swaggerParameterOtherSchemaCollectionFormat :: Maybe SwaggerCollectionFormat
288+
289+ -- | Declares the value of the parameter that the server will use if none is provided,
290+ -- for example a @"count"@ to control the number of results per page might default to @100@
291+ -- if not supplied by the client in the request.
292+ -- (Note: "default" has no meaning for required parameters.)
293+ -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
294+ , swaggerParameterOtherSchemaDefault :: Maybe JSON.Value
295+
296+ , swaggerParameterOtherSchemaMaximum :: Maybe Integer
297+ , swaggerParameterOtherSchemaExclusiveMaximum :: Maybe Bool
298+ , swaggerParameterOtherSchemaMinimum :: Maybe Integer
299+ , swaggerParameterOtherSchemaExclusiveMinimum :: Maybe Bool
300+ , swaggerParameterOtherSchemaMaxLength :: Maybe Integer
301+ , swaggerParameterOtherSchemaMinLength :: Maybe Integer
302+ , swaggerParameterOtherSchemaPattern :: Maybe Text
303+ , swaggerParameterOtherSchemaMaxItems :: Maybe Integer
304+ , swaggerParameterOtherSchemaMinItems :: Maybe Integer
305+ , swaggerParameterOtherSchemaUniqueItems :: Maybe Bool
306+ , swaggerParameterOtherSchemaEnum :: Maybe [JSON.Value]
307+ , swaggerParameterOtherSchemaMultipleOf :: Maybe Integer
308+ } deriving (Show)
309+
310+data SwaggerParameterType
311+ = SwaggerParamString
312+ | SwaggerParamNumber
313+ | SwaggerParamInteger
314+ | SwaggerParamBoolean
315+ | SwaggerParamArray
316+ | SwaggerParamFile
317+ deriving (Show)
318+
319+data SwaggerParameterLocation
499320 = -- | Parameters that are appended to the URL.
500321 -- For example, in @/items?id=###@, the query parameter is @id@.
501− ParamQuery
322+ SwaggerParameterQuery
502323 -- | Custom headers that are expected as part of the request.
503− | ParamHeader
324+ | SwaggerParameterHeader
504325 -- | Used together with Path Templating, where the parameter value is actually part of the operation's URL.
505326 -- This does not include the host or base path of the API.
506327 -- For example, in @/items/{itemId}@, the path parameter is @itemId@.
507− | ParamPath
328+ | SwaggerParameterPath
508329 -- | Used to describe the payload of an HTTP request when either @application/x-www-form-urlencoded@
509330 -- or @multipart/form-data@ are used as the content type of the request
510331 -- (in Swagger's definition, the @consumes@ property of an operation).
511− -- This is the only parameter type that can be used to send files, thus supporting the @'ParamFile'@ type.
332+ -- This is the only parameter type that can be used to send files, thus supporting the @'SwaggerParamFile'@ type.
512333 -- Since form parameters are sent in the payload, they cannot be declared together with a body parameter for the same operation.
513334 -- Form parameters have a different format based on the content-type used
514335 -- (for further details, consult <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>).
515− | ParamFormData
516− deriving (Eq, Show, Generic, Data, Typeable)
336+ | SwaggerParameterFormData
337+ deriving (Show)
517338
518−type Format = Text
339+type SwaggerFormat = Text
519340
520341-- | Determines the format of the array.
521−data CollectionFormat t where
522− -- Comma separated values: @foo,bar@.
523− CollectionCSV :: CollectionFormat t
524− -- Space separated values: @foo bar@.
525− CollectionSSV :: CollectionFormat t
526− -- Tab separated values: @foo\\tbar@.
527− CollectionTSV :: CollectionFormat t
528− -- Pipe separated values: @foo|bar@.
529− CollectionPipes :: CollectionFormat t
530− -- Corresponds to multiple parameter instances
531− -- instead of multiple values for a single instance @foo=bar&foo=baz@.
532− -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
534− deriving (Typeable)
535−
536−deriving instance Eq (CollectionFormat t)
537−deriving instance Show (CollectionFormat t)
538−
539−collectionFormatConstr :: CollectionFormat t -> Constr
540−collectionFormatConstr cf = mkConstr collectionFormatDataType (show cf) [] Prefix
541−
542−collectionFormatDataType :: DataType
543−collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
544− map collectionFormatConstr collectionCommonFormats
545−
546−collectionCommonFormats :: [CollectionFormat t]
547−collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
548−
549−instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
550− gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
551− toConstr = collectionFormatConstr
552− dataTypeOf _ = collectionFormatDataType
553−
554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
555−
556−type ParamName = Text
557−
558−data Schema = Schema
559− { _schemaTitle :: Maybe Text
560− , _schemaDescription :: Maybe Text
561− , _schemaRequired :: [ParamName]
562−
563− , _schemaAllOf :: Maybe [Referenced Schema]
564− , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565− , _schemaAdditionalProperties :: Maybe AdditionalProperties
566−
567− , _schemaDiscriminator :: Maybe Text
568− , _schemaReadOnly :: Maybe Bool
569− , _schemaXml :: Maybe Xml
570− , _schemaExternalDocs :: Maybe ExternalDocs
571− , _schemaExample :: Maybe Value
572−
573− , _schemaMaxProperties :: Maybe Integer
574− , _schemaMinProperties :: Maybe Integer
575−
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
584− } deriving (Eq, Show, Generic, Data, Typeable)
585−
586−-- | Regex pattern for @string@ type.
587−type Pattern = Text
588−
589−data ParamSchema (t :: SwaggerKind *) = ParamSchema
342+data SwaggerCollectionFormat
343+ = SwaggerCollectionCSV -- ^ Comma separated values: @foo,bar@.
344+ | SwaggerCollectionSSV -- ^ Space separated values @foo bar@.
345+ | SwaggerCollectionTSV -- ^ Tab separated values @foo\\tbar@.
346+ | SwaggerCollectionPipes -- ^ Pipe separated values @foo|bar@.
347+ -- | Corresponds to multiple parameter instances
348+ -- instead of multiple values for a single instance @foo=bar&foo=baz@.
349+ -- This is valid only for parameters in @'SwaggerParameterQuery'@ or @'SwaggerParameterFormData'@.
350+ | SwaggerCollectionMulti
351+ deriving (Show)
352+
353+data SwaggerItemsType
354+ = SwaggerItemsString
355+ | SwaggerItemsNumber
356+ | SwaggerItemsInteger
357+ | SwaggerItemsBoolean
358+ | SwaggerItemsArray
359+ deriving (Show)
360+
361+data SwaggerSchemaType
362+ = SwaggerSchemaArray
363+ | SwaggerSchemaBoolean
364+ | SwaggerSchemaInteger
365+ | SwaggerSchemaNumber
366+ | SwaggerSchemaNull
367+ | SwaggerSchemaObject
368+ | SwaggerSchemaString
369+ deriving (Show)
370+
371+-- | Determines the format of the nested array.
372+data SwaggerItemsCollectionFormat
373+ = SwaggerItemsCollectionCSV -- ^ Comma separated values: @foo,bar@.
374+ | SwaggerItemsCollectionSSV -- ^ Space separated values @foo bar@.
375+ | SwaggerItemsCollectionTSV -- ^ Tab separated values @foo\\tbar@.
376+ | SwaggerItemsCollectionPipes -- ^ Pipe separated values @foo|bar@.
377+ deriving (Show)
378+
379+data SwaggerSchema = SwaggerSchema
380+ { swaggerSchemaType :: SwaggerSchemaType
381+ , swaggerSchemaFormat :: SwaggerFormat
382+ , swaggerSchemaTitle :: Maybe Text
383+ , swaggerSchemaDescription :: Maybe Text
384+ , swaggerSchemaRequired :: Maybe Bool
385+
386+ , swaggerSchemaItems :: SwaggerSchemaItems
387+ , swaggerSchemaAllOf :: [SwaggerSchema]
388+ , swaggerSchemaProperties :: HashMap Text SwaggerSchema
389+ , swaggerSchemaAdditionalProperties :: Maybe SwaggerSchema
390+
391+ , swaggerSchemaDiscriminator :: Maybe Text
392+ , swaggerSchemaReadOnly :: Maybe Bool
393+ , swaggerSchemaXml :: Maybe SwaggerXml
394+ , swaggerSchemaExternalDocs :: Maybe SwaggerExternalDocs
395+ , swaggerSchemaExample :: Maybe JSON.Value
396+
397+ , swaggerSchemaMaxProperties :: Maybe Integer
398+ , swaggerSchemaMinProperties :: Maybe Integer
399+
400+ , swaggerSchemaCommon :: SwaggerSchemaCommon
401+ } deriving (Show)
402+
403+data SwaggerSchemaItems
404+ = SwaggerSchemaItemsObject SwaggerSchema
405+ | SwaggerSchemaItemsArray [SwaggerSchema]
406+ deriving (Show)
407+
408+data SwaggerSchemaCommon = SwaggerSchemaCommon
590409 { -- | Declares the value of the parameter that the server will use if none is provided,
591410 -- for example a @"count"@ to control the number of results per page might default to @100@
592411 -- if not supplied by the client in the request.
593412 -- (Note: "default" has no meaning for required parameters.)
594413 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
595− _paramSchemaDefault :: Maybe Value
596−
597− , _paramSchemaType :: Maybe (SwaggerType t)
598− , _paramSchemaFormat :: Maybe Format
599− , _paramSchemaItems :: Maybe (SwaggerItems t)
600− , _paramSchemaMaximum :: Maybe Scientific
601− , _paramSchemaExclusiveMaximum :: Maybe Bool
602− , _paramSchemaMinimum :: Maybe Scientific
603− , _paramSchemaExclusiveMinimum :: Maybe Bool
604− , _paramSchemaMaxLength :: Maybe Integer
605− , _paramSchemaMinLength :: Maybe Integer
606− , _paramSchemaPattern :: Maybe Pattern
607− , _paramSchemaMaxItems :: Maybe Integer
608− , _paramSchemaMinItems :: Maybe Integer
609− , _paramSchemaUniqueItems :: Maybe Bool
610− , _paramSchemaEnum :: Maybe [Value]
611− , _paramSchemaMultipleOf :: Maybe Scientific
612− } deriving (Eq, Show, Generic, Typeable)
613−
614−deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
615−
616−data Xml = Xml
414+ swaggerSchemaDefault :: Maybe JSON.Value
415+
416+ , swaggerSchemaMaximum :: Maybe Integer
417+ , swaggerSchemaExclusiveMaximum :: Maybe Bool
418+ , swaggerSchemaMinimum :: Maybe Integer
419+ , swaggerSchemaExclusiveMinimum :: Maybe Bool
420+ , swaggerSchemaMaxLength :: Maybe Integer
421+ , swaggerSchemaMinLength :: Maybe Integer
422+ , swaggerSchemaPattern :: Maybe Text
423+ , swaggerSchemaMaxItems :: Maybe Integer
424+ , swaggerSchemaMinItems :: Maybe Integer
425+ , swaggerSchemaUniqueItems :: Maybe Bool
426+ , swaggerSchemaEnum :: Maybe [JSON.Value]
427+ , swaggerSchemaMultipleOf :: Maybe Integer
428+ } deriving (Show)
429+
430+data SwaggerXml = SwaggerXml
617431 { -- | Replaces the name of the element/attribute used for the described schema property.
618432 -- When defined within the @'SwaggerItems'@ (items), it will affect the name of the individual XML elements within the list.
619433 -- When defined alongside type being array (outside the items),
620434 -- it will affect the wrapping element and only if wrapped is true.
621435 -- If wrapped is false, it will be ignored.
622− _xmlName :: Maybe Text
436+ swaggerXmlName :: Maybe Text
623437
624438 -- | The URL of the namespace definition.
625439 -- Value SHOULD be in the form of a URL.
626− , _xmlNamespace :: Maybe Text
440+ , swaggerXmlNamespace :: Maybe Text
627441
628442 -- | The prefix to be used for the name.
629− , _xmlPrefix :: Maybe Text
443+ , swaggerXmlPrefix :: Maybe Text
630444
631445 -- | Declares whether the property definition translates to an attribute instead of an element.
632446 -- Default value is @False@.
633− , _xmlAttribute :: Maybe Bool
447+ , swaggerXmlAttribute :: Bool
634448
635449 -- | MAY be used only for an array definition.
636450 -- Signifies whether the array is wrapped
@@ -638,87 +452,103 @@ data Xml = Xml
638452 -- or unwrapped (@\<book/\>\<book/\>@).
639453 -- Default value is @False@.
640454 -- The definition takes effect only when defined alongside type being array (outside the items).
641− , _xmlWrapped :: Maybe Bool
642− } deriving (Eq, Show, Generic, Data, Typeable)
455+ , swaggerXmlWrapped :: Bool
456+ } deriving (Show)
457+
458+data SwaggerItems = SwaggerItems
459+ { -- | The internal type of the array.
460+ swaggerItemsType :: SwaggerItemsType
461+
462+ -- | The extending format for the previously mentioned type.
463+ , swaggerItemsFormat :: SwaggerFormat
464+
465+ -- | __Required if type is @'SwaggerItemsArray'@.__
466+ -- Describes the type of items in the array.
467+ , swaggerItemsItems :: SwaggerItems
468+
469+ -- | Determines the format of the array if type array is used.
470+ -- Default value is @'SwaggerItemsCollectionCSV'@.
471+ , swaggerItemsCollectionFormat :: SwaggerItemsCollectionFormat
472+
473+ , swaggerItemsCommon :: SwaggerSchemaCommon
474+ } deriving (Show)
643475
644476-- | A container for the expected responses of an operation.
645477-- The container maps a HTTP response code to the expected response.
646478-- It is not expected from the documentation to necessarily cover all possible HTTP response codes,
647479-- since they may not be known in advance.
648480-- However, it is expected from the documentation to cover a successful operation response and any known errors.
649−data Responses = Responses
481+data SwaggerResponses = SwaggerResponses
650482 { -- | The documentation of responses other than the ones declared for specific HTTP response codes.
651483 -- It can be used to cover undeclared responses.
652− _responsesDefault :: Maybe (Referenced Response)
484+ swaggerResponsesDefault :: Maybe SwaggerResponse
653485
654486 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
655487 -- Describes the expected response for those HTTP status codes.
656− , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
657− } deriving (Eq, Show, Generic, Data, Typeable)
488+ , swaggerResponsesResponses :: HashMap HttpStatusCode SwaggerResponse
489+ } deriving (Show)
658490
659491type HttpStatusCode = Int
660492
661493-- | Describes a single response from an API Operation.
662−data Response = Response
494+data SwaggerResponse = SwaggerResponse
663495 { -- | A short description of the response.
664496 -- GFM syntax can be used for rich text representation.
665− _responseDescription :: Text
497+ swaggerResponseDescription :: Text
666498
667499 -- | A definition of the response structure.
668500 -- It can be a primitive, an array or an object.
669501 -- If this field does not exist, it means no content is returned as part of the response.
670502 -- As an extension to the Schema Object, its root type value may also be "file".
671503 -- This SHOULD be accompanied by a relevant produces mime-type.
672− , _responseSchema :: Maybe (Referenced Schema)
504+ , swaggerResponseSchema :: Maybe SwaggerSchema
673505
674506 -- | A list of headers that are sent with the response.
675− , _responseHeaders :: InsOrdHashMap HeaderName Header
507+ , swaggerResponseHeaders :: HashMap HeaderName SwaggerHeader
676508
677509 -- | An example of the response message.
678− , _responseExamples :: Maybe Example
679− } deriving (Eq, Show, Generic, Data, Typeable)
680−
681−instance IsString Response where
682− fromString s = Response (fromString s) Nothing mempty Nothing
510+ , swaggerResponseExamples :: Maybe SwaggerExample
511+ } deriving (Show)
683512
684513type HeaderName = Text
685514
686−data Header = Header
515+data SwaggerHeader = SwaggerHeader
687516 { -- | A short description of the header.
688− _headerDescription :: Maybe Text
517+ swaggerHeaderDescription :: Maybe String
518+
519+ -- | The type of the object.
520+ , swaggerHeaderType :: SwaggerItemsType
689521
690− , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
691− } deriving (Eq, Show, Generic, Data, Typeable)
522+ -- | The extending format for the previously mentioned type. See Data Type Formats for further details.
523+ , swaggerHeaderFormat :: Maybe SwaggerFormat
692524
693−data Example = Example { getExample :: Map MediaType Value }
694− deriving (Eq, Show, Generic, Typeable)
525+ -- | __Required if type is @'SwaggerItemsArray'@__.
526+ -- Describes the type of items in the array.
527+ , swaggerHeaderItems :: SwaggerItems
695528
696−exampleConstr :: Constr
697−exampleConstr = mkConstr exampleDataType "Example" ["getExample"] Prefix
529+ -- | Determines the format of the array if type array is used.
530+ -- Default value is @'SwaggerItemsCollectionCSV'@.
531+ , swaggerHeaderCollectionFormat :: SwaggerItemsCollectionFormat
698532
699−exampleDataType :: DataType
700−exampleDataType = mkDataType "Data.Swagger.Example" [exampleConstr]
533+ , swaggerHeaderCommon :: SwaggerSchemaCommon
534+ } deriving (Show)
701535
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
536+data SwaggerExample = SwaggerExample
537+ deriving (Show)
708538
709539-- | The location of the API key.
710−data ApiKeyLocation
711− = ApiKeyQuery
712− | ApiKeyHeader
713− deriving (Eq, Show, Generic, Data, Typeable)
540+data SwaggerApiKeyLocation
541+ = SwaggerApiKeyQuery
542+ | SwaggerApiKeyHeader
543+ deriving (Show)
714544
715−data ApiKeyParams = ApiKeyParams
545+data SwaggerApiKeyParams = SwaggerApiKeyParams
716546 { -- | The name of the header or query parameter to be used.
717− _apiKeyName :: Text
547+ swaggerApiKeyName :: Text
718548
719549 -- | The location of the API key.
720− , _apiKeyIn :: ApiKeyLocation
721− } deriving (Eq, Show, Generic, Data, Typeable)
550+ , swaggerApiKeyIn :: SwaggerApiKeyLocation
551+ } deriving (Show)
722552
723553-- | The authorization URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
724554type AuthorizationURL = Text
@@ -726,702 +556,69 @@ type AuthorizationURL = Text
726556-- | The token URL to be used for OAuth2 flow. This SHOULD be in the form of a URL.
727557type TokenURL = Text
728558
729−data OAuth2Flow
730− = OAuth2Implicit AuthorizationURL
731− | OAuth2Password TokenURL
732− | OAuth2Application TokenURL
733− | OAuth2AccessCode AuthorizationURL TokenURL
734− deriving (Eq, Show, Generic, Data, Typeable)
559+data SwaggerOAuth2Flow
560+ = SwaggerOAuth2Implicit AuthorizationURL
561+ | SwaggerOAuth2Password TokenURL
562+ | SwaggerOAuth2Application TokenURL
563+ | SwaggerOAuth2AccessCode AuthorizationURL TokenURL
564+ deriving (Show)
735565
736−data OAuth2Params = OAuth2Params
566+data SwaggerOAuth2Params = SwaggerOAuth2Params
737567 { -- | The flow used by the OAuth2 security scheme.
738− _oauth2Flow :: OAuth2Flow
568+ swaggerOAuth2Flow :: SwaggerOAuth2Flow
739569
740570 -- | The available scopes for the OAuth2 security scheme.
741− , _oauth2Scopes :: InsOrdHashMap Text Text
742− } deriving (Eq, Show, Generic, Data, Typeable)
571+ , swaggerOAuth2Scopes :: HashMap Text Text
572+ } deriving (Show)
743573
744−data SecuritySchemeType
745− = SecuritySchemeBasic
746− | SecuritySchemeApiKey ApiKeyParams
747− | SecuritySchemeOAuth2 OAuth2Params
748− deriving (Eq, Show, Generic, Data, Typeable)
574+data SwaggerSecuritySchemeType
575+ = SwaggerSecuritySchemeBasic
576+ | SwaggerSecuritySchemeApiKey SwaggerApiKeyParams
577+ | SwaggerSecuritySchemeOAuth2 SwaggerOAuth2Params
578+ deriving (Show)
749579
750−data SecurityScheme = SecurityScheme
751− { -- | The type of the security scheme.
752− _securitySchemeType :: SecuritySchemeType
753−
754− -- | A short description for security scheme.
755− , _securitySchemeDescription :: Maybe Text
756− } deriving (Eq, Show, Generic, Data, Typeable)
580+data SwaggerSecuritySchemeTypeName
581+ = SwaggerSecuritySchemeTypeBasic
582+ | SwaggerSecuritySchemeTypeApiKey
583+ | SwaggerSecuritySchemeTypeOAuth2
584+ deriving (Show, Generic)
757585
586+instance Hashable SwaggerSecuritySchemeTypeName
758587
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
588+data SwaggerSecurityScheme = SwaggerSecurityScheme
589+ { -- | The type of the security scheme.
590+ swaggerSecuritySchemeType :: SwaggerSecuritySchemeType
769591
770−newtype SecurityDefinitions
771− = SecurityDefinitions (Definitions SecurityScheme)
772− deriving (Eq, Show, Generic, Data, Typeable)
592+ -- | A short description for security scheme.
593+ , swaggerSecuritySchemeDescription :: Maybe Text
594+ } deriving (Show)
773595
774596-- | Lists the required security schemes to execute this operation.
775597-- The object can have multiple security schemes declared in it which are all required
776598-- (that is, there is a logical AND between the schemes).
777−newtype SecurityRequirement = SecurityRequirement
778− { getSecurityRequirement :: InsOrdHashMap Text [Text]
779− } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
599+type SwaggerSecurityRequirement = HashMap SwaggerSecuritySchemeTypeName Text
780600
781−-- | Tag name.
782−type TagName = Text
783−
784−-- | Allows adding meta data to a single tag that is used by @Operation@.
785−-- It is not mandatory to have a @Tag@ per tag used there.
786−data Tag = Tag
601+-- | Allows adding meta data to a single tag that is used by @SwaggerOperation@.
602+-- It is not mandatory to have a @SwaggerTag@ per tag used there.
603+data SwaggerTag = SwaggerTag
787604 { -- | The name of the tag.
788− _tagName :: TagName
605+ swaggerTagName :: Text
789606
790607 -- | A short description for the tag.
791608 -- GFM syntax can be used for rich text representation.
792− , _tagDescription :: Maybe Text
609+ , swaggerTagDescription :: Maybe Text
793610
794611 -- | Additional external documentation for this tag.
795− , _tagExternalDocs :: Maybe ExternalDocs
796− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797−
798−instance Hashable Tag
799−
800−instance IsString Tag where
801− fromString s = Tag (fromString s) Nothing Nothing
612+ , swaggerTagExternalDocs :: Maybe SwaggerExternalDocs
613+ } deriving (Show)
802614
803615-- | Allows referencing an external resource for extended documentation.
804−data ExternalDocs = ExternalDocs
616+data SwaggerExternalDocs = SwaggerExternalDocs
805617 { -- | A short description of the target documentation.
806618 -- GFM syntax can be used for rich text representation.
807− _externalDocsDescription :: Maybe Text
619+ swaggerExternalDocsDescription :: Maybe Text
808620
809621 -- | The URL for the target documentation.
810− , _externalDocsUrl :: URL
811− } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812−
813−instance Hashable ExternalDocs
814−
815−-- | A simple object to allow referencing other definitions in the specification.
816−-- It can be used to reference parameters and responses that are defined at the top level for reuse.
817−newtype Reference = Reference { getReference :: Text }
818− deriving (Eq, Show, Data, Typeable)
819−
820−data Referenced a
821− = Ref Reference
822− | Inline a
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)
829−
830−data AdditionalProperties
831− = AdditionalPropertiesAllowed Bool
832− | AdditionalPropertiesSchema (Referenced Schema)
833− deriving (Eq, Show, Data, Typeable)
834−
835−-- =======================================================================
836−-- Monoid instances
837−-- =======================================================================
838−
839−instance Semigroup Swagger where
840− (<>) = genericMappend
841−instance Monoid Swagger where
842− mempty = genericMempty
843− mappend = (<>)
844−
845−instance Semigroup Info where
846− (<>) = genericMappend
847−instance Monoid Info where
848− mempty = genericMempty
849− mappend = (<>)
850−
851−instance Semigroup Contact where
852− (<>) = genericMappend
853−instance Monoid Contact where
854− mempty = genericMempty
855− mappend = (<>)
856−
857−instance Semigroup PathItem where
858− (<>) = genericMappend
859−instance Monoid PathItem where
860− mempty = genericMempty
861− mappend = (<>)
862−
863−instance Semigroup Schema where
864− (<>) = genericMappend
865−instance Monoid Schema where
866− mempty = genericMempty
867− mappend = (<>)
868−
869−instance Semigroup (ParamSchema t) where
870− (<>) = genericMappend
871−instance Monoid (ParamSchema t) where
872− mempty = genericMempty
873− mappend = (<>)
874−
875−instance Semigroup Param where
876− (<>) = genericMappend
877−instance Monoid Param where
878− mempty = genericMempty
879− mappend = (<>)
880−
881−instance Semigroup ParamOtherSchema where
882− (<>) = genericMappend
883−instance Monoid ParamOtherSchema where
884− mempty = genericMempty
885− mappend = (<>)
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
895−instance Monoid Responses where
896− mempty = genericMempty
897− mappend = (<>)
898−
899−instance Semigroup Response where
900− (<>) = genericMappend
901−instance Monoid Response where
902− mempty = genericMempty
903− mappend = (<>)
904−
905−instance Semigroup ExternalDocs where
906− (<>) = genericMappend
907−instance Monoid ExternalDocs where
908− mempty = genericMempty
909− mappend = (<>)
910−
911−instance Semigroup Operation where
912− (<>) = genericMappend
913−instance Monoid Operation where
914− mempty = genericMempty
915− mappend = (<>)
916−
917−instance Semigroup Example where
918− (<>) = genericMappend
919−instance Monoid Example where
920− mempty = genericMempty
921− mappend = (<>)
922−
923−instance Semigroup SecurityScheme where
924− (<>) = mergeSecurityScheme
925−
926−instance Semigroup SecurityDefinitions where
927− (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
928− SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
929−
930−instance Monoid SecurityDefinitions where
931− mempty = SecurityDefinitions $ InsOrdHashMap.empty
932− mappend = (<>)
933−
934−-- =======================================================================
935−-- SwaggerMonoid helper instances
936−-- =======================================================================
937−
938−instance SwaggerMonoid Info
939−instance SwaggerMonoid PathItem
940−instance SwaggerMonoid Schema
941−instance SwaggerMonoid (ParamSchema t)
942−instance SwaggerMonoid Param
943−instance SwaggerMonoid ParamOtherSchema
944−instance SwaggerMonoid Responses
945−instance SwaggerMonoid Response
946−instance SwaggerMonoid ExternalDocs
947−instance SwaggerMonoid Operation
948−instance SwaggerMonoid SecurityDefinitions
949−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
950−
951−instance SwaggerMonoid MimeList
952−deriving instance SwaggerMonoid URL
953−
954−instance SwaggerMonoid (SwaggerType t) where
955− swaggerMempty = SwaggerString
956− swaggerMappend _ y = y
957−
958−instance SwaggerMonoid ParamLocation where
959− swaggerMempty = ParamQuery
960− swaggerMappend _ y = y
961−
962−instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
963− swaggerMempty = InsOrdHashMap.empty
964− swaggerMappend = InsOrdHashMap.unionWith mappend
965−
966−instance Monoid a => SwaggerMonoid (Referenced a) where
967− swaggerMempty = Inline mempty
968− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
969− swaggerMappend _ y = y
970−
971−instance SwaggerMonoid ParamAnySchema where
972− swaggerMempty = ParamOther swaggerMempty
973− swaggerMappend (ParamBody x) (ParamBody y) = ParamBody (swaggerMappend x y)
974− swaggerMappend (ParamOther x) (ParamOther y) = ParamOther (swaggerMappend x y)
975− swaggerMappend _ y = y
976−
977−-- =======================================================================
978−-- Simple Generic-based ToJSON instances
979−-- =======================================================================
980−
981−instance ToJSON ParamLocation where
982− toJSON = genericToJSON (jsonPrefix "Param")
983−
984−instance ToJSON Info where
985− toJSON = genericToJSON (jsonPrefix "Info")
986−
987−instance ToJSON Contact where
988− toJSON = genericToJSON (jsonPrefix "Contact")
989−
990−instance ToJSON License where
991− toJSON = genericToJSON (jsonPrefix "License")
992−
993−instance ToJSON ApiKeyLocation where
994− toJSON = genericToJSON (jsonPrefix "ApiKey")
995−
996−instance ToJSON ApiKeyParams where
997− toJSON = genericToJSON (jsonPrefix "apiKey")
998−
999−instance ToJSON Scheme where
1000− toJSON = genericToJSON (jsonPrefix "")
1001−
1002−instance ToJSON Tag where
1003− toJSON = genericToJSON (jsonPrefix "Tag")
1004−
1005−instance ToJSON ExternalDocs where
1006− toJSON = genericToJSON (jsonPrefix "ExternalDocs")
1007−
1008−instance ToJSON Xml where
1009− toJSON = genericToJSON (jsonPrefix "Xml")
1010−
1011−-- =======================================================================
1012−-- Simple Generic-based FromJSON instances
1013−-- =======================================================================
1014−
1015−instance FromJSON ParamLocation where
1016− parseJSON = genericParseJSON (jsonPrefix "Param")
1017−
1018−instance FromJSON Info where
1019− parseJSON = genericParseJSON (jsonPrefix "Info")
1020−
1021−instance FromJSON Contact where
1022− parseJSON = genericParseJSON (jsonPrefix "Contact")
1023−
1024−instance FromJSON License where
1025− parseJSON = genericParseJSON (jsonPrefix "License")
1026−
1027−instance FromJSON ApiKeyLocation where
1028− parseJSON = genericParseJSON (jsonPrefix "ApiKey")
1029−
1030−instance FromJSON ApiKeyParams where
1031− parseJSON = genericParseJSON (jsonPrefix "apiKey")
1032−
1033−instance FromJSON Scheme where
1034− parseJSON = genericParseJSON (jsonPrefix "")
1035−
1036−instance FromJSON Tag where
1037− parseJSON = genericParseJSON (jsonPrefix "Tag")
1038−
1039−instance FromJSON ExternalDocs where
1040− parseJSON = genericParseJSON (jsonPrefix "ExternalDocs")
1041−
1042−-- =======================================================================
1043−-- Manual ToJSON instances
1044−-- =======================================================================
1045−
1046−instance ToJSON OAuth2Flow where
1047− toJSON (OAuth2Implicit authUrl) = object
1048− [ "flow" .= ("implicit" :: Text)
1049− , "authorizationUrl" .= authUrl ]
1050− toJSON (OAuth2Password tokenUrl) = object
1051− [ "flow" .= ("password" :: Text)
1052− , "tokenUrl" .= tokenUrl ]
1053− toJSON (OAuth2Application tokenUrl) = object
1054− [ "flow" .= ("application" :: Text)
1055− , "tokenUrl" .= tokenUrl ]
1056− toJSON (OAuth2AccessCode authUrl tokenUrl) = object
1057− [ "flow" .= ("accessCode" :: Text)
1058− , "authorizationUrl" .= authUrl
1059− , "tokenUrl" .= tokenUrl ]
1060−
1061−instance ToJSON OAuth2Params where
1062− toJSON = sopSwaggerGenericToJSON
1063− DEFINE_TOENCODING
1064−
1065−instance ToJSON SecuritySchemeType where
1066− toJSON SecuritySchemeBasic
1067− = object [ "type" .= ("basic" :: Text) ]
1068− toJSON (SecuritySchemeApiKey params)
1069− = toJSON params
1070− <+> object [ "type" .= ("apiKey" :: Text) ]
1071− toJSON (SecuritySchemeOAuth2 params)
1072− = toJSON params
1073− <+> object [ "type" .= ("oauth2" :: Text) ]
1074−
1075−instance ToJSON Swagger where
1076− toJSON = sopSwaggerGenericToJSON
1077− DEFINE_TOENCODING
1078−
1079−instance ToJSON SecurityScheme where
1080− toJSON = sopSwaggerGenericToJSON
1081− DEFINE_TOENCODING
1082−
1083−instance ToJSON Schema where
1084− toJSON = sopSwaggerGenericToJSON
1085− DEFINE_TOENCODING
1086−
1087−instance ToJSON Header where
1088− toJSON = sopSwaggerGenericToJSON
1089− DEFINE_TOENCODING
1090−
1091−-- | As for nullary schema for 0-arity type constructors, see
1092−-- <https://github.com/GetShopTV/swagger2/issues/167>.
1093−--
1094−-- >>> encode (SwaggerItemsArray [])
1095−-- "{\"example\":[],\"items\":{},\"maxItems\":0}"
1096−--
1097−instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
1098− toJSON (SwaggerItemsPrimitive fmt schema) = object
1099− [ "collectionFormat" .= fmt
1100− , "items" .= schema ]
1101− toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102− toJSON (SwaggerItemsArray []) = object
1103− [ "items" .= object []
1104− , "maxItems" .= (0 :: Int)
1105− , "example" .= Array mempty
1106− ]
1107− toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
1108−
1109−instance ToJSON Host where
1110− toJSON (Host host mport) = toJSON $
1111− case mport of
1112− Nothing -> host
1113− Just port -> host ++ ":" ++ show port
1114−
1115−instance ToJSON MimeList where
1116− toJSON (MimeList xs) = toJSON (map show xs)
1117−
1118−instance ToJSON Param where
1119− toJSON = sopSwaggerGenericToJSON
1120− DEFINE_TOENCODING
1121−
1122−instance ToJSON ParamAnySchema where
1123− toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1124− toJSON (ParamOther s) = toJSON s
1125−
1126−instance ToJSON ParamOtherSchema where
1127− toJSON = sopSwaggerGenericToJSON
1128− DEFINE_TOENCODING
1129−
1130−instance ToJSON Responses where
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
1145−
1146−instance ToJSON Example where
1147− toJSON = toJSON . Map.mapKeys show . getExample
1148−
1149−instance ToJSON SecurityDefinitions where
1150− toJSON (SecurityDefinitions sd) = toJSON sd
1151−
1152−instance ToJSON Reference where
1153− toJSON (Reference ref) = object [ "$ref" .= ref ]
1154−
1155−referencedToJSON :: ToJSON a => Text -> Referenced a -> Value
1156−referencedToJSON prefix (Ref (Reference ref)) = object [ "$ref" .= (prefix <> ref) ]
1157−referencedToJSON _ (Inline x) = toJSON x
1158−
1159−instance ToJSON (Referenced Schema) where toJSON = referencedToJSON "#/definitions/"
1160−instance ToJSON (Referenced Param) where toJSON = referencedToJSON "#/parameters/"
1161−instance ToJSON (Referenced Response) where toJSON = referencedToJSON "#/responses/"
1162−
1163−instance ToJSON (SwaggerType t) where
1164− toJSON SwaggerArray = "array"
1165− toJSON SwaggerString = "string"
1166− toJSON SwaggerInteger = "integer"
1167− toJSON SwaggerNumber = "number"
1168− toJSON SwaggerBoolean = "boolean"
1169− toJSON SwaggerFile = "file"
1170− toJSON SwaggerNull = "null"
1171− toJSON SwaggerObject = "object"
1172−
1173−instance ToJSON (CollectionFormat t) where
1174− toJSON CollectionCSV = "csv"
1175− toJSON CollectionSSV = "ssv"
1176− toJSON CollectionTSV = "tsv"
1177− toJSON CollectionPipes = "pipes"
1178− toJSON CollectionMulti = "multi"
1179−
1180−instance ToJSON (ParamSchema k) where
1181− -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?
1182− toJSON = sopSwaggerGenericToJSONWithOpts $
1183− mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1184−
1185−instance ToJSON AdditionalProperties where
1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187− toJSON (AdditionalPropertiesSchema s) = toJSON s
1188−
1189−-- =======================================================================
1190−-- Manual FromJSON instances
1191−-- =======================================================================
1192−
1193−instance FromJSON OAuth2Flow where
1194− parseJSON (Object o) = do
1195− (flow :: Text) <- o .: "flow"
1196− case flow of
1197− "implicit" -> OAuth2Implicit <$> o .: "authorizationUrl"
1198− "password" -> OAuth2Password <$> o .: "tokenUrl"
1199− "application" -> OAuth2Application <$> o .: "tokenUrl"
1200− "accessCode" -> OAuth2AccessCode
1201− <$> o .: "authorizationUrl"
1202− <*> o .: "tokenUrl"
1203− _ -> empty
1204− parseJSON _ = empty
1205−
1206−instance FromJSON OAuth2Params where
1207− parseJSON = sopSwaggerGenericParseJSON
1208−
1209−instance FromJSON SecuritySchemeType where
1210− parseJSON js@(Object o) = do
1211− (t :: Text) <- o .: "type"
1212− case t of
1213− "basic" -> pure SecuritySchemeBasic
1214− "apiKey" -> SecuritySchemeApiKey <$> parseJSON js
1215− "oauth2" -> SecuritySchemeOAuth2 <$> parseJSON js
1216− _ -> empty
1217− parseJSON _ = empty
1218−
1219−instance FromJSON Swagger where
1220− parseJSON = sopSwaggerGenericParseJSON
1221−
1222−instance FromJSON SecurityScheme where
1223− parseJSON = sopSwaggerGenericParseJSON
1224−
1225−instance FromJSON Schema where
1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1227− where nullaryCleanup :: Schema -> Schema
1228− nullaryCleanup s@Schema{_schemaParamSchema=ps} =
1229− if _paramSchemaItems ps == Just (SwaggerItemsArray [])
1230− then s { _schemaExample = Nothing
1231− , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }
1232− else s
1233−
1234−instance FromJSON Header where
1235− parseJSON = sopSwaggerGenericParseJSON
1236−
1237−instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
1238− parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1239− <$> o .:? "collectionFormat"
1240− <*> (o .: "items" >>= parseJSON)
1241−
1242−instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
1243− parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
1244− <$> o .:? "collectionFormat"
1245− <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1246−
1247−-- |
1248−--
1249−-- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema)
1250−-- Just (SwaggerItemsArray [])
1251−--
1252−-- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema)
1253−-- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"})))
1254−--
1255−-- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema)
1256−-- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})])
1257−--
1258−instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1259− parseJSON js@(Object obj)
1260− | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1261− | otherwise = SwaggerItemsObject <$> parseJSON js
1262− parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1263− parseJSON _ = empty
1264−
1265−instance FromJSON Host where
1266− parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of
1267− [host] -> return $ Host host Nothing
1268− [host, port] -> case readMaybe port of
1269− Nothing -> fail $ "Invalid port `" ++ port ++ "'"
1270− Just p -> return $ Host host (Just (fromInteger p))
1271− _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'"
1272− parseJSON _ = empty
1273−
1274−instance FromJSON MimeList where
1275− parseJSON js = (MimeList . map fromString) <$> parseJSON js
1276−
1277−instance FromJSON Param where
1278− parseJSON = sopSwaggerGenericParseJSON
1279−
1280−instance FromJSON ParamAnySchema where
1281− parseJSON js@(Object o) = do
1282− (i :: Text) <- o .: "in"
1283− case i of
1284− "body" -> do
1285− schema <- o .: "schema"
1286− ParamBody <$> parseJSON schema
1287− _ -> ParamOther <$> parseJSON js
1288− parseJSON _ = empty
1289−
1290−instance FromJSON ParamOtherSchema where
1291− parseJSON = sopSwaggerGenericParseJSON
1292−
1293−instance FromJSON Responses where
1294− parseJSON (Object o) = Responses
1295− <$> o .:? "default"
1296− <*> (parseJSON (Object (HashMap.delete "default" o)))
1297− parseJSON _ = empty
1298−
1299−instance FromJSON Example where
1300− parseJSON js = do
1301− m <- parseJSON js
1302− pure $ Example (Map.mapKeys fromString m)
1303−
1304−instance FromJSON Response where
1305− parseJSON = sopSwaggerGenericParseJSON
1306−
1307−instance FromJSON Operation where
1308− parseJSON = sopSwaggerGenericParseJSON
1309−
1310−instance FromJSON PathItem where
1311− parseJSON = sopSwaggerGenericParseJSON
1312−
1313−instance FromJSON SecurityDefinitions where
1314− parseJSON js = SecurityDefinitions <$> parseJSON js
1315−
1316−instance FromJSON Reference where
1317− parseJSON (Object o) = Reference <$> o .: "$ref"
1318− parseJSON _ = empty
1319−
1320−referencedParseJSON :: FromJSON a => Text -> Value -> JSON.Parser (Referenced a)
1321−referencedParseJSON prefix js@(Object o) = do
1322− ms <- o .:? "$ref"
1323− case ms of
1324− Nothing -> Inline <$> parseJSON js
1325− Just s -> Ref <$> parseRef s
1326− where
1327− parseRef s = do
1328− case Text.stripPrefix prefix s of
1329− Nothing -> fail $ "expected $ref of the form \"" <> Text.unpack prefix <> "*\", but got " <> show s
1330− Just suffix -> pure (Reference suffix)
1331−referencedParseJSON _ _ = fail "referenceParseJSON: not an object"
1332−
1333−instance FromJSON (Referenced Schema) where parseJSON = referencedParseJSON "#/definitions/"
1334−instance FromJSON (Referenced Param) where parseJSON = referencedParseJSON "#/parameters/"
1335−instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#/responses/"
1336−
1337−instance FromJSON Xml where
1338− parseJSON = genericParseJSON (jsonPrefix "xml")
1339−
1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where
1341− parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
1342−
1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
1344− parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
1345−
1346−instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
1347− parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
1348−
1349−instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
1350− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1351−
1352−-- NOTE: There aren't collections of 'Schema'
1353−--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where
1354−-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
1355−
1356−instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where
1357− parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
1358−
1359−instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where
1360− parseJSON = sopSwaggerGenericParseJSON
1361−instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
1362− parseJSON = sopSwaggerGenericParseJSON
1363−instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1364− parseJSON = sopSwaggerGenericParseJSON
1365−
1366−instance FromJSON AdditionalProperties where
1367− parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1369−
1370−-------------------------------------------------------------------------------
1371−-- TH splices
1372−-------------------------------------------------------------------------------
1373−
1374−deriveGeneric ''Header
1375−deriveGeneric ''OAuth2Params
1376−deriveGeneric ''Operation
1377−deriveGeneric ''Param
1378−deriveGeneric ''ParamOtherSchema
1379−deriveGeneric ''PathItem
1380−deriveGeneric ''Response
1381−deriveGeneric ''Responses
1382−deriveGeneric ''SecurityScheme
1383−deriveGeneric ''Schema
1384−deriveGeneric ''ParamSchema
1385−deriveGeneric ''Swagger
1386−
1387−instance HasSwaggerAesonOptions Header where
1388− swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"
1389−instance HasSwaggerAesonOptions OAuth2Params where
1390− swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"
1391−instance HasSwaggerAesonOptions Operation where
1392− swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"
1393−instance HasSwaggerAesonOptions Param where
1394− swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"
1395−instance HasSwaggerAesonOptions ParamOtherSchema where
1396− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"
1397−instance HasSwaggerAesonOptions PathItem where
1398− swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"
1399−instance HasSwaggerAesonOptions Response where
1400− swaggerAesonOptions _ = mkSwaggerAesonOptions "response"
1401−instance HasSwaggerAesonOptions Responses where
1402− swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"
1403−instance HasSwaggerAesonOptions SecurityScheme where
1404− swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"
1405−instance HasSwaggerAesonOptions Schema where
1406− swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"
1407−instance HasSwaggerAesonOptions Swagger where
1408− swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]
1409−
1410−instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where
1411− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1412−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where
1413− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1414−-- NOTE: Schema doesn't have 'items' sub object!
1415−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where
1416− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"
1417−
1418−instance AesonDefaultValue (ParamSchema s)
1419−instance AesonDefaultValue OAuth2Flow
1420−instance AesonDefaultValue Responses
1421−instance AesonDefaultValue ParamAnySchema
1422−instance AesonDefaultValue SecuritySchemeType
1423−instance AesonDefaultValue (SwaggerType a)
1424−instance AesonDefaultValue MimeList where defaultValue = Just mempty
1425−instance AesonDefaultValue Info
1426−instance AesonDefaultValue ParamLocation
1427−instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty
622+ , swaggerExternalDocsURL :: URL
623+ } deriving (Show)
624+
src/Data/Swagger/Internal/AesonUtils.hsdeleted−346
@@ -1,346 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE ExplicitForAll #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−#if __GLASGOW_HASKELL__ >= 800
9−{-# LANGUAGE UndecidableSuperClasses #-}
10−#endif
11−module Data.Swagger.Internal.AesonUtils (
12− -- * Generic functions
13− AesonDefaultValue(..),
14− sopSwaggerGenericToJSON,
15−#if MIN_VERSION_aeson(0,10,0)
16− sopSwaggerGenericToEncoding,
17−#endif
18− sopSwaggerGenericToJSONWithOpts,
19− sopSwaggerGenericParseJSON,
20− -- * Options
21− HasSwaggerAesonOptions(..),
22− SwaggerAesonOptions,
23− mkSwaggerAesonOptions,
24− saoPrefix,
25− saoAdditionalPairs,
26− saoSubObject,
27− ) where
28−
29−import Prelude ()
30−import Prelude.Compat
31−
32−import Control.Applicative ((<|>))
33−import Control.Lens (makeLenses, (^.))
34−import Control.Monad (unless)
35−import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)
36−import Data.Aeson.Types (Parser, Pair)
37−import Data.Char (toLower, isUpper)
38−import Data.Foldable (traverse_)
39−import Data.Text (Text)
40−
41−import Generics.SOP
42−
43−import qualified Data.Text as T
44−import qualified Data.HashMap.Strict as HM
45−import qualified Data.Set as Set
46−import qualified Data.HashMap.Strict.InsOrd as InsOrd
47−import qualified Data.HashSet.InsOrd as InsOrdHS
48−
49−#if MIN_VERSION_aeson(0,10,0)
50−import Data.Aeson (Encoding, pairs, (.=), Series)
51−#endif
52−
53−-------------------------------------------------------------------------------
54−-- SwaggerAesonOptions
55−-------------------------------------------------------------------------------
56−
57−data SwaggerAesonOptions = SwaggerAesonOptions
58− { _saoPrefix :: String
59− , _saoAdditionalPairs :: [(Text, Value)]
60− , _saoSubObject :: Maybe String
61− }
62−
63−mkSwaggerAesonOptions
64− :: String -- ^ prefix
65− -> SwaggerAesonOptions
66−mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
67−
68−makeLenses ''SwaggerAesonOptions
69−
70−class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions
72−
73− -- So far we use only default definitions
74− aesonDefaults :: Proxy a -> POP Maybe (Code a)
75− aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
76−
77−-------------------------------------------------------------------------------
78−-- Generics
79−-------------------------------------------------------------------------------
80−
81−class AesonDefaultValue a where
82− defaultValue :: Maybe a
83− defaultValue = Nothing
84−
85−instance AesonDefaultValue Text where defaultValue = Nothing
86−instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
87−instance AesonDefaultValue [a] where defaultValue = Just []
88−instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
89−instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty
90−instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
91−
92−-------------------------------------------------------------------------------
93−-- ToJSON
94−-------------------------------------------------------------------------------
95−
96−-- | Generic serialisation for swagger records.
97−--
98−-- Features
99−--
100−-- * omits nulls, empty objects and empty arrays (configurable)
101−-- * possible to add fields
102−-- * possible to merge sub-object
103−sopSwaggerGenericToJSON
104− :: forall a xs.
105− ( HasDatatypeInfo a
106− , HasSwaggerAesonOptions a
107− , All2 ToJSON (Code a)
108− , All2 Eq (Code a)
109− , Code a ~ '[xs]
110− )
111− => a
112− -> Value
113−sopSwaggerGenericToJSON x =
114− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
115− in object (opts ^. saoAdditionalPairs ++ ps)
116− where
117− proxy = Proxy :: Proxy a
118− opts = swaggerAesonOptions proxy
119−
120−-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
121−--
122−-- Also uses default `aesonDefaults`
123−sopSwaggerGenericToJSONWithOpts
124− :: forall a xs.
125− ( Generic a
126− , All2 AesonDefaultValue (Code a)
127− , HasDatatypeInfo a
128− , All2 ToJSON (Code a)
129− , All2 Eq (Code a)
130− , Code a ~ '[xs]
131− )
132− => SwaggerAesonOptions
133− -> a
134− -> Value
135−sopSwaggerGenericToJSONWithOpts opts x =
136− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs
137− in object (opts ^. saoAdditionalPairs ++ ps)
138− where
139− proxy = Proxy :: Proxy a
140− defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
141−
142−sopSwaggerGenericToJSON'
143− :: (All2 ToJSON '[xs], All2 Eq '[xs])
144− => SwaggerAesonOptions
145− -> SOP I '[xs]
146− -> DatatypeInfo '[xs]
147− -> POP Maybe '[xs]
148− -> [Pair]
149−#if MIN_VERSION_generics_sop(0,5,0)
150−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
151−#else
152−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
153−#endif
154− sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
155−sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
156−
157−sopSwaggerGenericToJSON''
158− :: (All ToJSON xs, All Eq xs)
159− => SwaggerAesonOptions
160− -> NP I xs
161− -> NP FieldInfo xs
162− -> NP Maybe xs
163− -> [Pair]
164−sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
165− where
166− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
167− go Nil Nil Nil = []
168− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
169− | Just name' == sub = case json of
170− Object m -> HM.toList m ++ rest
171− Null -> rest
172− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
173− -- If default value: omit it.
174− | Just x == def =
175− rest
176− | otherwise =
177− (T.pack name', json) : rest
178− where
179− json = toJSON x
180− name' = fieldNameModifier name
181− rest = go xs names defs
182−#if __GLASGOW_HASKELL__ < 800
183− go _ _ _ = error "not empty"
184−#endif
185−
186− fieldNameModifier = modifier . drop 1
187− modifier = lowerFirstUppers . drop (length prefix)
188− lowerFirstUppers s = map toLower x ++ y
189− where (x, y) = span isUpper s
190−
191−-------------------------------------------------------------------------------
192−-- FromJSON
193−-------------------------------------------------------------------------------
194−
195−sopSwaggerGenericParseJSON
196− :: forall a xs.
197− ( HasDatatypeInfo a
198− , HasSwaggerAesonOptions a
199− , All2 FromJSON (Code a)
200− , All2 Eq (Code a)
201− , Code a ~ '[xs]
202− )
203− => Value
204− -> Parser a
205−sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
206− let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)
207− in do
208− traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)
209− to <$> ps
210− where
211− proxy = Proxy :: Proxy a
212− opts = swaggerAesonOptions proxy
213−
214− parseAdditionalField :: Object -> (Text, Value) -> Parser ()
215− parseAdditionalField obj (k, v) = do
216− v' <- obj .: k
217− unless (v == v') $ fail $
218− "Additonal field don't match for key " ++ T.unpack k
219− ++ ": " ++ show v
220− ++ " /= " ++ show v'
221−
222−sopSwaggerGenericParseJSON'
223− :: (All2 FromJSON '[xs], All2 Eq '[xs])
224− => SwaggerAesonOptions
225− -> Object
226− -> DatatypeInfo '[xs]
227− -> POP Maybe '[xs]
228− -> Parser (SOP I '[xs])
229−#if MIN_VERSION_generics_sop(0,5,0)
230−sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
231−#else
232−sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
233−#endif
234− SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
235−sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
236−
237−sopSwaggerGenericParseJSON''
238− :: (All FromJSON xs, All Eq xs)
239− => SwaggerAesonOptions
240− -> Object
241− -> NP FieldInfo xs
242− -> NP Maybe xs
243− -> Parser (NP I xs)
244−sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
245− where
246− go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
247− go Nil Nil = pure Nil
248− go (FieldInfo name :* names) (def :* defs)
249− | Just name' == sub =
250− -- Note: we might strip fields of outer structure.
251− cons <$> (withDef $ parseJSON $ Object obj) <*> rest
252− | otherwise = case def of
253− Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest
254− Nothing -> cons <$> obj .: T.pack name' <*> rest
255− where
256− cons h t = I h :* t
257− name' = fieldNameModifier name
258− rest = go names defs
259−
260− withDef = case def of
261− Just def' -> (<|> pure def')
262− Nothing -> id
263−#if __GLASGOW_HASKELL__ < 800
264− go _ _ = error "not empty"
265−#endif
266−
267− fieldNameModifier = modifier . drop 1
268− modifier = lowerFirstUppers . drop (length prefix)
269− lowerFirstUppers s = map toLower x ++ y
270− where (x, y) = span isUpper s
271−
272−-------------------------------------------------------------------------------
273−-- ToEncoding
274−-------------------------------------------------------------------------------
275−
276−#if MIN_VERSION_aeson(0,10,0)
277−
278−sopSwaggerGenericToEncoding
279− :: forall a xs.
280− ( HasDatatypeInfo a
281− , HasSwaggerAesonOptions a
282− , All2 ToJSON (Code a)
283− , All2 Eq (Code a)
284− , Code a ~ '[xs]
285− )
286− => a
287− -> Encoding
288−sopSwaggerGenericToEncoding x =
289− let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
290− in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)
291− where
292− proxy = Proxy :: Proxy a
293− opts = swaggerAesonOptions proxy
294−
295−pairsToSeries :: [Pair] -> Series
296−pairsToSeries = foldMap (\(k, v) -> (k .= v))
297−
298−sopSwaggerGenericToEncoding'
299− :: (All2 ToJSON '[xs], All2 Eq '[xs])
300− => SwaggerAesonOptions
301− -> SOP I '[xs]
302− -> DatatypeInfo '[xs]
303− -> POP Maybe '[xs]
304− -> Series
305−#if MIN_VERSION_generics_sop(0,5,0)
306−sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
307−#else
308−sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
309−#endif
310− sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
311−sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
312−
313−sopSwaggerGenericToEncoding''
314− :: (All ToJSON xs, All Eq xs)
315− => SwaggerAesonOptions
316− -> NP I xs
317− -> NP FieldInfo xs
318− -> NP Maybe xs
319− -> Series
320−sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
321− where
322− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
323− go Nil Nil Nil = mempty
324− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
325− | Just name' == sub = case toJSON x of
326− Object m -> pairsToSeries (HM.toList m) <> rest
327− Null -> rest
328− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
329− -- If default value: omit it.
330− | Just x == def =
331− rest
332− | otherwise =
333− (T.pack name' .= x) <> rest
334− where
335− name' = fieldNameModifier name
336− rest = go xs names defs
337−#if __GLASGOW_HASKELL__ < 800
338− go _ _ _ = error "not empty"
339−#endif
340−
341− fieldNameModifier = modifier . drop 1
342− modifier = lowerFirstUppers . drop (length prefix)
343− lowerFirstUppers s = map toLower x ++ y
344− where (x, y) = span isUpper s
345−
346−#endif
src/Data/Swagger/Internal/ParamSchema.hsdeleted−337
@@ -1,337 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DefaultSignatures #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PackageImports #-}
9−{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE TypeSynonymInstances #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−#if __GLASGOW_HASKELL__ >= 800
16−-- Generic a is redundant in ToParamSchema a default imple
17−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
18−-- For TypeErrors
19−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
20−#endif
21−#include "overlapping-compat.h"
22−module Data.Swagger.Internal.ParamSchema where
23−
24−import Control.Lens
25−import Data.Aeson (ToJSON (..))
26−import Data.Proxy
27−import GHC.Generics
28−
29−import Data.Int
30−import "unordered-containers" Data.HashSet (HashSet)
31−import Data.Monoid
32−import Data.Set (Set)
33−import Data.Scientific
34−import Data.Fixed (HasResolution(..), Fixed, Pico)
35−import qualified Data.Text as T
36−import qualified Data.Text.Lazy as TL
37−import Data.Time
38−import qualified Data.Vector as V
39−import qualified Data.Vector.Primitive as VP
40−import qualified Data.Vector.Storable as VS
41−import qualified Data.Vector.Unboxed as VU
42−import Data.Version (Version)
43−import Numeric.Natural.Compat (Natural)
44−import Data.Word
45−import Data.UUID.Types (UUID)
46−import Web.Cookie (SetCookie)
47−
48−import Data.Swagger.Internal
49−import Data.Swagger.Lens
50−import Data.Swagger.SchemaOptions
51−
52−#if __GLASGOW_HASKELL__ < 800
53−#else
54−import qualified Data.ByteString as BS
55−import qualified Data.ByteString.Lazy as BSL
56−import GHC.TypeLits (TypeError, ErrorMessage(..))
57−#endif
58−
59−-- | Default schema for binary data (any sequence of octets).
60−binaryParamSchema :: ParamSchema t
61−binaryParamSchema = mempty
62− & type_ ?~ SwaggerString
63− & format ?~ "binary"
64−
65−-- | Default schema for binary data (base64 encoded).
66−byteParamSchema :: ParamSchema t
67−byteParamSchema = mempty
68− & type_ ?~ SwaggerString
69− & format ?~ "byte"
70−
71−-- | Default schema for password string.
72−-- @"password"@ format is used to hint UIs the input needs to be obscured.
73−passwordParamSchema :: ParamSchema t
74−passwordParamSchema = mempty
75− & type_ ?~ SwaggerString
76− & format ?~ "password"
77−
78−-- | Convert a type into a plain @'ParamSchema'@.
79−--
80−-- An example type and instance:
81−--
82−-- @
83−-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
84−--
85−-- import Control.Lens
86−--
87−-- data Direction = Up | Down
88−--
89−-- instance ToParamSchema Direction where
90−-- toParamSchema _ = mempty
91−-- & type_ ?~ SwaggerString
92−-- & enum_ ?~ [ \"Up\", \"Down\" ]
93−-- @
94−--
95−-- Instead of manually writing your @'ToParamSchema'@ instance you can
96−-- use a default generic implementation of @'toParamSchema'@.
97−--
98−-- To do that, simply add @deriving 'Generic'@ clause to your datatype
99−-- and declare a @'ToParamSchema'@ instance for your datatype without
100−-- giving definition for @'toParamSchema'@.
101−--
102−-- For instance, the previous example can be simplified into this:
103−--
104−-- @
105−-- {-\# LANGUAGE DeriveGeneric \#-}
106−--
107−-- import GHC.Generics (Generic)
108−--
109−-- data Direction = Up | Down deriving Generic
110−--
111−-- instance ToParamSchema Direction
112−-- @
113−class ToParamSchema a where
114− -- | Convert a type into a plain parameter schema.
115− --
116− -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
117− -- "{\"type\":\"integer\"}"
118− toParamSchema :: Proxy a -> ParamSchema t
119− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
120− toParamSchema = genericToParamSchema defaultSchemaOptions
121−
122−instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ ?~ SwaggerString
124−
125−instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
127−
128−instance ToParamSchema Integer where
129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger
130−
131−instance ToParamSchema Natural where
132− toParamSchema _ = mempty
133− & type_ ?~ SwaggerInteger
134− & minimum_ ?~ 0
135− & exclusiveMinimum ?~ False
136−
137−instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
138−instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
139−instance ToParamSchema Int16 where toParamSchema = toParamSchemaBoundedIntegral
140−
141−instance ToParamSchema Int32 where
142− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int32"
143−
144−instance ToParamSchema Int64 where
145− toParamSchema proxy = toParamSchemaBoundedIntegral proxy & format ?~ "int64"
146−
147−instance ToParamSchema Word where toParamSchema = toParamSchemaBoundedIntegral
148−instance ToParamSchema Word8 where toParamSchema = toParamSchemaBoundedIntegral
149−instance ToParamSchema Word16 where toParamSchema = toParamSchemaBoundedIntegral
150−instance ToParamSchema Word32 where toParamSchema = toParamSchemaBoundedIntegral
151−instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
152−
153−-- | Default plain schema for @'Bounded'@, @'Integral'@ types.
154−--
155−-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156−-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
158−toParamSchemaBoundedIntegral _ = mempty
159− & type_ ?~ SwaggerInteger
160− & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161− & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162−
163−instance ToParamSchema Char where
164− toParamSchema _ = mempty
165− & type_ ?~ SwaggerString
166− & maxLength ?~ 1
167− & minLength ?~ 1
168−
169−instance ToParamSchema Scientific where
170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber
171−
172−instance HasResolution a => ToParamSchema (Fixed a) where
173− toParamSchema _ = mempty
174− & type_ ?~ SwaggerNumber
175− & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
176−
177−instance ToParamSchema Double where
178− toParamSchema _ = mempty
179− & type_ ?~ SwaggerNumber
180− & format ?~ "double"
181−
182−instance ToParamSchema Float where
183− toParamSchema _ = mempty
184− & type_ ?~ SwaggerNumber
185− & format ?~ "float"
186−
187−timeParamSchema :: String -> ParamSchema t
188−timeParamSchema fmt = mempty
189− & type_ ?~ SwaggerString
190− & format ?~ T.pack fmt
191−
192−-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
193−instance ToParamSchema Day where
194− toParamSchema _ = timeParamSchema "date"
195−
196−-- |
197−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198−-- Just "hh:MM:ss"
199−instance ToParamSchema TimeOfDay where
200− toParamSchema _ = timeParamSchema "hh:MM:ss"
201−
202−-- |
203−-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
204−-- Just "yyyy-mm-ddThh:MM:ss"
205−instance ToParamSchema LocalTime where
206− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss"
207−
208−-- |
209−-- >>> toParamSchema (Proxy :: Proxy ZonedTime) ^. format
210−-- Just "yyyy-mm-ddThh:MM:ss+hhMM"
211−instance ToParamSchema ZonedTime where
212− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ss+hhMM"
213−
214−-- |
215−-- >>> toParamSchema (Proxy :: Proxy UTCTime) ^. format
216−-- Just "yyyy-mm-ddThh:MM:ssZ"
217−instance ToParamSchema UTCTime where
218− toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
219−
220−instance ToParamSchema NominalDiffTime where
221− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
222−
223−instance ToParamSchema T.Text where
224− toParamSchema _ = toParamSchema (Proxy :: Proxy String)
225−
226−instance ToParamSchema TL.Text where
227− toParamSchema _ = toParamSchema (Proxy :: Proxy String)
228−
229−instance ToParamSchema Version where
230− toParamSchema _ = mempty
231− & type_ ?~ SwaggerString
232− & pattern ?~ "^\\d+(\\.\\d+)*$"
233−
234−instance ToParamSchema SetCookie where
235− toParamSchema _ = mempty
236− & type_ ?~ SwaggerString
237−
238−
239−#if __GLASGOW_HASKELL__ < 800
240−#else
241−type family ToParamSchemaByteStringError bs where
242− ToParamSchemaByteStringError bs = TypeError
243− ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "."
244− :$$: 'Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
245− :$$: 'Text "Consider using byteParamSchema or binaryParamSchema templates." )
246−
247−instance ToParamSchemaByteStringError BS.ByteString => ToParamSchema BS.ByteString where toParamSchema = error "impossible"
248−instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible"
249−#endif
250−
251−instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
252−instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
253−instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
254−instance ToParamSchema a => ToParamSchema (Product a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
255−instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
256−instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
257−instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
258−
259−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
260−
261−instance ToParamSchema a => ToParamSchema [a] where
262− toParamSchema _ = mempty
263− & type_ ?~ SwaggerArray
264− & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
265−
266−instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
267−instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
268−instance ToParamSchema a => ToParamSchema (VS.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
269−instance ToParamSchema a => ToParamSchema (VU.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
270−
271−instance ToParamSchema a => ToParamSchema (Set a) where
272− toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
273− & uniqueItems ?~ True
274−
275−instance ToParamSchema a => ToParamSchema (HashSet a) where
276− toParamSchema _ = toParamSchema (Proxy :: Proxy (Set a))
277−
278−-- |
279−-- >>> encode $ toParamSchema (Proxy :: Proxy ())
280−-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
281−instance ToParamSchema () where
282− toParamSchema _ = mempty
283− & type_ ?~ SwaggerString
284− & enum_ ?~ ["_"]
285−
286−instance ToParamSchema UUID where
287− toParamSchema _ = mempty
288− & type_ ?~ SwaggerString
289− & format ?~ "uuid"
290−
291−-- | A configurable generic @'ParamSchema'@ creator.
292−--
293−-- >>> :set -XDeriveGeneric
294−-- >>> data Color = Red | Blue deriving Generic
295−-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
296−-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
298−genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
299−
300−class GToParamSchema (f :: * -> *) where
301− gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
302−
303−instance GToParamSchema f => GToParamSchema (D1 d f) where
304− gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
305−
306−instance Constructor c => GToParamSchema (C1 c U1) where
307− gtoParamSchema = genumParamSchema
308−
309−instance GToParamSchema f => GToParamSchema (C1 c (S1 s f)) where
310− gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
311−
312−instance ToParamSchema c => GToParamSchema (K1 i c) where
313− gtoParamSchema _ _ _ = toParamSchema (Proxy :: Proxy c)
314−
315−instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) where
316− gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
317−
318−class GEnumParamSchema (f :: * -> *) where
319− genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
320−
321−instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
322− genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
323−
324−instance Constructor c => GEnumParamSchema (C1 c U1) where
325− genumParamSchema opts _ s = s
326− & type_ ?~ SwaggerString
327− & enum_ %~ addEnumValue tag
328− where
329− tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
330−
331− addEnumValue x Nothing = Just [x]
332− addEnumValue x (Just xs) = Just (x:xs)
333−
334−data Proxy3 a b c = Proxy3
335−
336−-- $setup
337−-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hsdeleted−882
@@ -1,882 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DefaultSignatures #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE DataKinds #-}
8−{-# LANGUAGE OverloadedLists #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE TypeOperators #-}
16−{-# LANGUAGE TypeSynonymInstances #-}
17−{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ >= 800
19−-- Few generics related redundant constraints
20−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
21−-- For TypeErrors
22−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
23−#endif
24−#include "overlapping-compat.h"
25−module Data.Swagger.Internal.Schema where
26−
27−import Prelude ()
28−import Prelude.Compat
29−
30−import Control.Lens
31−import Data.Data.Lens (template)
32−
33−import Control.Monad
34−import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
36−import Data.Char
37−import Data.Data (Data)
38−import Data.Foldable (traverse_)
39−import Data.HashMap.Strict (HashMap)
40−import qualified Data.HashMap.Strict as HashMap
41−import "unordered-containers" Data.HashSet (HashSet)
42−import qualified "unordered-containers" Data.HashSet as HashSet
43−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
44−import Data.Int
45−import Data.IntSet (IntSet)
46−import Data.IntMap (IntMap)
47−import Data.List.NonEmpty.Compat (NonEmpty)
48−import Data.Map (Map)
49−import Data.Proxy
50−import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
52−import Data.Set (Set)
53−import qualified Data.Text as T
54−import qualified Data.Text.Lazy as TL
55−import Data.Time
56−import qualified Data.Vector as V
57−import qualified Data.Vector.Primitive as VP
58−import qualified Data.Vector.Storable as VS
59−import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
62−import Data.Word
63−import GHC.Generics
64−import qualified Data.UUID.Types as UUID
65−
66−import Data.Swagger.Declare
67−import Data.Swagger.Internal
68−import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
69−import Data.Swagger.Lens hiding (name, schema)
70−import qualified Data.Swagger.Lens as Swagger
71−import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
73−
74−#if __GLASGOW_HASKELL__ < 800
75−#else
76−import qualified Data.ByteString as BS
77−import qualified Data.ByteString.Lazy as BSL
78−import GHC.TypeLits (TypeError, ErrorMessage(..))
79−#endif
80−
81−unnamed :: Schema -> NamedSchema
82−unnamed schema = NamedSchema Nothing schema
83−
84−named :: T.Text -> Schema -> NamedSchema
85−named name schema = NamedSchema (Just name) schema
86−
87−plain :: Schema -> Declare (Definitions Schema) NamedSchema
88−plain = pure . unnamed
89−
90−unname :: NamedSchema -> NamedSchema
91−unname (NamedSchema _ schema) = unnamed schema
92−
93−rename :: Maybe T.Text -> NamedSchema -> NamedSchema
94−rename name (NamedSchema _ schema) = NamedSchema name schema
95−
96−-- | Convert a type into @'Schema'@.
97−--
98−-- An example type and instance:
99−--
100−-- @
101−-- {-\# LANGUAGE OverloadedStrings \#-} -- allows to write 'T.Text' literals
102−-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
103−--
104−-- import Control.Lens
105−-- import Data.Proxy
106−-- import Data.Swagger
107−--
108−-- data Coord = Coord { x :: Double, y :: Double }
109−--
110−-- instance ToSchema Coord where
111−-- declareNamedSchema _ = do
112−-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113−-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ ?~ SwaggerObject
115−-- & properties .~
116−-- [ (\"x\", doubleSchema)
117−-- , (\"y\", doubleSchema)
118−-- ]
119−-- & required .~ [ \"x\", \"y\" ]
120−-- @
121−--
122−-- Instead of manually writing your @'ToSchema'@ instance you can
123−-- use a default generic implementation of @'declareNamedSchema'@.
124−--
125−-- To do that, simply add @deriving 'Generic'@ clause to your datatype
126−-- and declare a @'ToSchema'@ instance for your datatype without
127−-- giving definition for @'declareNamedSchema'@.
128−--
129−-- For instance, the previous example can be simplified into this:
130−--
131−-- @
132−-- {-\# LANGUAGE DeriveGeneric \#-}
133−--
134−-- import GHC.Generics (Generic)
135−--
136−-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
137−--
138−-- instance ToSchema Coord
139−-- @
140−class ToSchema a where
141− -- | Convert a type into an optionally named schema
142− -- together with all used definitions.
143− -- Note that the schema itself is included in definitions
144− -- only if it is recursive (and thus needs its definition in scope).
145− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
146− default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
147− Proxy a -> Declare (Definitions Schema) NamedSchema
148− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149−
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154−-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
156−declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157−
158−-- | Convert a type into an optionally named schema.
159−--
160−-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
161−-- Nothing
162−-- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
163−-- "{\"type\":\"string\"}"
164−--
165−-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
166−-- Just "Day"
167−-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168−-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
170−toNamedSchema = undeclare . declareNamedSchema
171−
172−-- | Get type's schema name according to its @'ToSchema'@ instance.
173−--
174−-- >>> schemaName (Proxy :: Proxy Int)
175−-- Nothing
176−--
177−-- >>> schemaName (Proxy :: Proxy UTCTime)
178−-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
180−schemaName = _namedSchemaName . toNamedSchema
181−
182−-- | Convert a type into a schema.
183−--
184−-- >>> encode $ toSchema (Proxy :: Proxy Int8)
185−-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
186−--
187−-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188−-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
190−toSchema = _namedSchemaSchema . toNamedSchema
191−
192−-- | Convert a type into a referenced schema if possible.
193−-- Only named schemas can be referenced, nameless schemas are inlined.
194−--
195−-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer)
196−-- "{\"type\":\"integer\"}"
197−--
198−-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199−-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
201−toSchemaRef = undeclare . declareSchemaRef
202−
203−-- | Convert a type into a referenced schema if possible
204−-- and declare all used schema definitions.
205−-- Only named schemas can be referenced, nameless schemas are inlined.
206−--
207−-- Schema definitions are typically declared for every referenced schema.
208−-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209−-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
211−declareSchemaRef proxy = do
212− case toNamedSchema proxy of
213− NamedSchema (Just name) schema -> do
214− -- This check is very important as it allows generically
215− -- derive used definitions for recursive schemas.
216− -- Lazy Declare monad allows toNamedSchema to ignore
217− -- any declarations (which would otherwise loop) and
218− -- retrieve the schema and its name to check if we
219− -- have already declared it.
220− -- If we have, we don't need to declare anything for
221− -- this schema this time and thus simply return the reference.
222− known <- looks (InsOrdHashMap.member name)
223− when (not known) $ do
224− declare [(name, schema)]
225− void $ declareNamedSchema proxy
226− return $ Ref (Reference name)
227− _ -> Inline <$> declareSchema proxy
228−
229−-- | Inline any referenced schema if its name satisfies given predicate.
230−--
231−-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored
232−-- and schema stays referenced.
233−--
234−-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas
235−-- when inlining recursive schemas.
236−inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s
237−inlineSchemasWhen p defs = template %~ deref
238− where
239− deref r@(Ref (Reference name))
240− | p name =
241− case InsOrdHashMap.lookup name defs of
242− Just schema -> Inline (inlineSchemasWhen p defs schema)
243− Nothing -> r
244− | otherwise = r
245− deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)
246−
247−-- | Inline any referenced schema if its name is in the given list.
248−--
249−-- /NOTE:/ if a referenced schema is not found in definitions
250−-- it stays referenced even if it appears in the list of names.
251−--
252−-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas
253−-- when inlining recursive schemas.
254−inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s
255−inlineSchemas names = inlineSchemasWhen (`elem` names)
256−
257−-- | Inline all schema references for which the definition
258−-- can be found in @'Definitions'@.
259−--
260−-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas
261−-- when inlining recursive schemas.
262−inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s
263−inlineAllSchemas = inlineSchemasWhen (const True)
264−
265−-- | Convert a type into a schema without references.
266−--
267−-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
269−--
270−-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271−-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
273−toInlinedSchema proxy = inlineAllSchemas defs schema
274− where
275− (defs, schema) = runDeclare (declareSchema proxy) mempty
276−
277−-- | Inline all /non-recursive/ schemas for which the definition
278−-- can be found in @'Definitions'@.
279−inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
280−inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
281− where
282− nonRecursive name =
283− case InsOrdHashMap.lookup name defs of
284− Just schema -> name `notElem` execDeclare (usedNames schema) mempty
285− Nothing -> False
286−
287− usedNames schema = traverse_ schemaRefNames (schema ^.. template)
288−
289− schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
290− schemaRefNames ref = case ref of
291− Ref (Reference name) -> do
292− seen <- looks (name `elem`)
293− when (not seen) $ do
294− declare [name]
295− traverse_ usedNames (InsOrdHashMap.lookup name defs)
296− Inline subschema -> usedNames subschema
297−
298−-- | Default schema for binary data (any sequence of octets).
299−binarySchema :: Schema
300−binarySchema = mempty
301− & type_ ?~ SwaggerString
302− & format ?~ "binary"
303−
304−-- | Default schema for binary data (base64 encoded).
305−byteSchema :: Schema
306−byteSchema = mempty
307− & type_ ?~ SwaggerString
308− & format ?~ "byte"
309−
310−-- | Default schema for password string.
311−-- @"password"@ format is used to hint UIs the input needs to be obscured.
312−passwordSchema :: Schema
313−passwordSchema = mempty
314− & type_ ?~ SwaggerString
315− & format ?~ "password"
316−
317−-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
318−-- Produced schema can be used for further refinement.
319−--
320−-- >>> encode $ sketchSchema "hello"
321−-- "{\"example\":\"hello\",\"type\":\"string\"}"
322−--
323−-- >>> encode $ sketchSchema (1, 2, 3)
324−-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"
325−--
326−-- >>> encode $ sketchSchema ("Jack", 25)
327−-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"
328−--
329−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
330−-- >>> instance ToJSON Person
331−-- >>> encode $ sketchSchema (Person "Jack" 25)
332−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
333−sketchSchema :: ToJSON a => a -> Schema
334−sketchSchema = sketch . toJSON
335− where
336− sketch Null = go Null
337− sketch js@(Bool _) = go js
338− sketch js = go js & example ?~ js
339−
340− go Null = mempty & type_ ?~ SwaggerNull
341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
342− go (String _) = mempty & type_ ?~ SwaggerString
343− go (Number _) = mempty & type_ ?~ SwaggerNumber
344− go (Array xs) = mempty
345− & type_ ?~ SwaggerArray
346− & items ?~ case ischema of
347− Just s -> SwaggerItemsObject (Inline s)
348− _ -> SwaggerItemsArray (map Inline ys)
349− where
350− ys = map go (V.toList xs)
351− allSame = and ((zipWith (==)) ys (tail ys))
352−
353− ischema = case ys of
354− (z:_) | allSame -> Just z
355− _ -> Nothing
356− go (Object o) = mempty
357− & type_ ?~ SwaggerObject
358− & required .~ HashMap.keys o
359− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
360−
361−-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
362−-- Produced schema uses as much constraints as possible.
363−--
364−-- >>> encode $ sketchStrictSchema "hello"
365−-- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"
366−--
367−-- >>> encode $ sketchStrictSchema (1, 2, 3)
368−-- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}"
369−--
370−-- >>> encode $ sketchStrictSchema ("Jack", 25)
371−-- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}"
372−--
373−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
374−-- >>> instance ToJSON Person
375−-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
376−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}"
377−sketchStrictSchema :: ToJSON a => a -> Schema
378−sketchStrictSchema = go . toJSON
379− where
380− go Null = mempty & type_ ?~ SwaggerNull
381− go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
383− & enum_ ?~ [js]
384− go js@(String s) = mempty
385− & type_ ?~ SwaggerString
386− & maxLength ?~ fromIntegral (T.length s)
387− & minLength ?~ fromIntegral (T.length s)
388− & pattern ?~ s
389− & enum_ ?~ [js]
390− go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
392− & maximum_ ?~ n
393− & minimum_ ?~ n
394− & multipleOf ?~ n
395− & enum_ ?~ [js]
396− go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
398− & maxItems ?~ fromIntegral sz
399− & minItems ?~ fromIntegral sz
400− & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
401− & uniqueItems ?~ allUnique
402− & enum_ ?~ [js]
403− where
404− sz = length xs
405− allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406− go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
408− & required .~ names
409− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410− & maxProperties ?~ fromIntegral (length names)
411− & minProperties ?~ fromIntegral (length names)
412− & enum_ ?~ [js]
413− where
414− names = HashMap.keys o
415−
416−class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418−
419−instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420− declareNamedSchema _ = do
421− ref <- declareSchemaRef (Proxy :: Proxy a)
422− return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
424− & items ?~ SwaggerItemsObject ref
425−
426−instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427−instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428−instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430−instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431−instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432−instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
433−instance ToSchema Int32 where declareNamedSchema = plain . paramSchemaToSchema
434−instance ToSchema Int64 where declareNamedSchema = plain . paramSchemaToSchema
435−instance ToSchema Word where declareNamedSchema = plain . paramSchemaToSchema
436−instance ToSchema Word8 where declareNamedSchema = plain . paramSchemaToSchema
437−instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
438−instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
439−instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
440−
441−instance ToSchema Char where
442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
443− & mapped.Swagger.schema.example ?~ toJSON '?'
444−
445−instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
446−instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447−instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448−
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451−instance ToSchema a => ToSchema (Maybe a) where
452− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453−
454−instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
455−
456−instance ToSchema () where
457− declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
458−
459−-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.
460−instance ToSchema UUID.UUID where
461− declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
462− & example ?~ toJSON (UUID.toText UUID.nil)
463−
464−instance (ToSchema a, ToSchema b) => ToSchema (a, b)
465−instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
466−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
467−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
468−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
469−instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)
470−
471−timeSchema :: T.Text -> Schema
472−timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
474− & format ?~ fmt
475−
476−-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
477−instance ToSchema Day where
478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
479− & example ?~ toJSON (fromGregorian 2016 7 22)
480−
481−-- |
482−-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
483−-- Just "yyyy-mm-ddThh:MM:ss"
484−instance ToSchema LocalTime where
485− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
486− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))
487−
488−-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
489−instance ToSchema ZonedTime where
490− declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
491− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492−
493−instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
495−
496−-- |
497−-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
498−-- Just "yyyy-mm-ddThh:MM:ssZ"
499−instance ToSchema UTCTime where
500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)
502−
503−instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504−instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505−
506−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
507−
508−#if __GLASGOW_HASKELL__ < 800
509−#else
510−type family ToSchemaByteStringError bs where
511− ToSchemaByteStringError bs = TypeError
512− ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."
513− :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
514− :$$: Text "Consider using byteSchema or binarySchema templates." )
515−
516−instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible"
517−instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"
518−#endif
519−
520−instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
521−
522−-- | NOTE: This schema does not account for the uniqueness of keys.
523−instance ToSchema a => ToSchema (IntMap a) where
524− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
525−
526−#if MIN_VERSION_aeson(1,0,0)
527−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
528− declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of
529− ToJSONKeyText _ _ -> declareObjectMapSchema
530− ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])
531− where
532− declareObjectMapSchema = do
533− schema <- declareSchemaRef (Proxy :: Proxy v)
534− return $ unnamed $ mempty
535− & type_ ?~ SwaggerObject
536− & additionalProperties ?~ AdditionalPropertiesSchema schema
537−
538−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
539− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
540−
541−#else
542−
543−instance ToSchema a => ToSchema (Map String a) where
544− declareNamedSchema _ = do
545− schema <- declareSchemaRef (Proxy :: Proxy a)
546− return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
548− & additionalProperties ?~ schema
549−
550−instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
551−instance ToSchema a => ToSchema (Map TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
552−
553−instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
554−instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
555−instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
556−
557−#endif
558−
559−instance OVERLAPPING_ ToSchema Object where
560− declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
561− & type_ ?~ SwaggerObject
562− & description ?~ "Arbitrary JSON object."
563− & additionalProperties ?~ AdditionalPropertiesAllowed True
564−
565−instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566−instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567−instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
568−instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
569−
570−instance ToSchema a => ToSchema (Set a) where
571− declareNamedSchema _ = do
572− schema <- declareSchema (Proxy :: Proxy [a])
573− return $ unnamed $ schema
574− & uniqueItems ?~ True
575−
576−instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577−
578−-- | @since 2.2.1
579−instance ToSchema a => ToSchema (NonEmpty a) where
580− declareNamedSchema _ = do
581− schema <- declareSchema (Proxy :: Proxy [a])
582− return $ unnamed $ schema
583− & minItems .~ Just 1
584−
585−instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586−instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587−
588−instance ToSchema a => ToSchema (Sum a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
589−instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
590−instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
591−instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592−instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593−
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596−-- | Default schema for @'Bounded'@, @'Integral'@ types.
597−--
598−-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599−-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
601−toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
603− & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604− & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605−
606−-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
608− ( Bounded a, Integral a
609− , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
611−genericToNamedSchemaBoundedIntegral opts proxy
612− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
613−
614−-- | Declare a named schema for a @newtype@ wrapper.
615−genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
616− (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617− => SchemaOptions -- ^ How to derive the name.
618− -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619− -> Proxy a
620− -> Declare (Definitions Schema) NamedSchema
621−genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622−
623−-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
624−-- This makes a much more useful schema when there aren't many options for key values.
625−--
626−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
627−-- >>> instance ToJSON ButtonState
628−-- >>> instance ToSchema ButtonState
629−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
630−-- >>> type ImageUrl = T.Text
631−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
632−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
633−--
634−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636−declareSchemaBoundedEnumKeyMapping :: forall map key value.
637− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638− => Proxy (map key value) -> Declare (Definitions Schema) Schema
639−declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640− ToJSONKeyText keyToText _ -> objectSchema keyToText
641− ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
642− where
643− objectSchema keyToText = do
644− valueRef <- declareSchemaRef (Proxy :: Proxy value)
645− let allKeys = [minBound..maxBound :: key]
646− mkPair k = (keyToText k, valueRef)
647− return $ mempty
648− & type_ ?~ SwaggerObject
649− & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650−
651−-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
652−-- This makes a much more useful schema when there aren't many options for key values.
653−--
654−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
655−-- >>> instance ToJSON ButtonState
656−-- >>> instance ToSchema ButtonState
657−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
658−-- >>> type ImageUrl = T.Text
659−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
660−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
661−--
662−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664−toSchemaBoundedEnumKeyMapping :: forall map key value.
665− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666− => Proxy (map key value) -> Schema
667−toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
668−
669−-- | A configurable generic @'Schema'@ creator.
670−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
672−genericDeclareSchema = genericDeclareSchemaUnrestricted
673−
674−-- | A configurable generic @'NamedSchema'@ creator.
675−-- This function applied to @'defaultSchemaOptions'@
676−-- is used as the default for @'declareNamedSchema'@
677−-- when the type is an instance of @'Generic'@.
678−genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
679− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
680−genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
681−
682−-- | A configurable generic @'Schema'@ creator.
683−--
684−-- Unlike 'genericDeclareSchema' also works for mixed sum types.
685−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
686−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
687−genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
688−
689−-- | A configurable generic @'NamedSchema'@ creator.
690−--
691−-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
692−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
693−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
694− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
695−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
696−
697−-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698−genericNameSchema :: forall a d f.
699− (Generic a, Rep a ~ D1 d f, Datatype d)
700− => SchemaOptions -> Proxy a -> Schema -> NamedSchema
701−genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
702−
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
705− (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706− _ -> Nothing
707− where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
709− name = datatypeNameModifier opts orig
710−
711−-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
713− SchemaOptions -> Proxy a -> NamedSchema
714−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
715−
716−-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
719−
720−nullarySchema :: Schema
721−nullarySchema = mempty
722− & type_ ?~ SwaggerArray
723− & items ?~ SwaggerItemsArray []
724−
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
726−gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727−
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
729−gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730−
731−instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
732− gdeclareNamedSchema opts _ schema = do
733− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
734− gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
735−
736−instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
737− gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
738− where
739− name = gdatatypeSchemaName opts (Proxy :: Proxy d)
740−
741−instance OVERLAPPABLE_ GToSchema f => GToSchema (C1 c f) where
742− gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)
743−
744−instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745− gdeclareNamedSchema = gdeclareNamedSumSchema
746−
747−-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
749− gdeclareNamedSchema opts _ s
750− | unwrapUnaryRecords opts = fieldSchema
751− | otherwise =
752− case schema ^. items of
753− Just (SwaggerItemsArray [_]) -> fieldSchema
754− _ -> do
755− declare defs
756− return (unnamed schema)
757− where
758− (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
759− recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760− fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761−
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
763−gdeclareSchemaRef opts proxy = do
764− case gtoNamedSchema opts proxy of
765− NamedSchema (Just name) schema -> do
766− -- This check is very important as it allows generically
767− -- derive used definitions for recursive schemas.
768− -- Lazy Declare monad allows toNamedSchema to ignore
769− -- any declarations (which would otherwise loop) and
770− -- retrieve the schema and its name to check if we
771− -- have already declared it.
772− -- If we have, we don't need to declare anything for
773− -- this schema this time and thus simply return the reference.
774− known <- looks (InsOrdHashMap.member name)
775− when (not known) $ do
776− declare [(name, schema)]
777− void $ gdeclareNamedSchema opts proxy mempty
778− return $ Ref (Reference name)
779− _ -> Inline <$> gdeclareSchema opts proxy
780−
781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
782−appendItem x Nothing = Just (SwaggerItemsArray [x])
783−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
784−appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
785−
786−withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
787− SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
788−withFieldSchema opts _ isRequiredField schema = do
789− ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
790− return $
791− if T.null fname
792− then schema
793− & type_ ?~ SwaggerArray
794− & items %~ appendItem ref
795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796− & minItems %~ Just . maybe 1 (+1) -- increment minItems
797− else schema
798− & type_ ?~ SwaggerObject
799− & properties . at fname ?~ ref
800− & if isRequiredField
801− then required %~ (++ [fname])
802− else id
803− where
804− fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
805−
806−-- | Optional record fields.
807−instance OVERLAPPING_ (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
808− gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False
809−
810−-- | Record fields.
811−instance OVERLAPPABLE_ (Selector s, GToSchema f) => GToSchema (S1 s f) where
812− gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True
813−
814−instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
815− gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
816−
817−instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
818− gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819−
820−instance ( GSumToSchema f
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
824− gdeclareNamedSchema = gdeclareNamedSumSchema
825−
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827−gdeclareNamedSumSchema opts proxy s
828− | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829− | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
830− where
831− declareSumSchema = gsumToSchema opts proxy s
832− (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833−
834− toStringTag schema = mempty
835− & type_ ?~ SwaggerString
836− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837−
838−type AllNullary = All
839−
840−class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842−
843−instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
845−
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
848−gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
850− & properties . at tag ?~ ref
851− & maxProperties ?~ 1
852− & minProperties ?~ 1
853− where
854− tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855−
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858−gsumConToSchema opts proxy schema = do
859− ref <- gdeclareSchemaRef opts proxy
860− return $ gsumConToSchemaWith ref opts proxy schema
861−
862−instance OVERLAPPABLE_ (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
863− gsumToSchema opts proxy schema = do
864− tell (All False)
865− lift $ gsumConToSchema opts proxy schema
866−
867−instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
868− gsumToSchema opts proxy schema = do
869− tell (All False)
870− lift $ gsumConToSchema opts proxy schema
871−
872−instance Constructor c => GSumToSchema (C1 c U1) where
873− gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy
874−
875−data Proxy2 a b = Proxy2
876−
877−data Proxy3 a b c = Proxy3
878−
879−-- $setup
880−-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hsdeleted−511
@@ -1,511 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE UndecidableInstances #-}
15−-- |
16−-- Module: Data.Swagger.Internal.Schema.Validation
17−-- Copyright: (c) 2015 GetShopTV
18−-- License: BSD3
19−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
20−-- Stability: experimental
21−--
22−-- Validate JSON values with Swagger Schema.
23−module Data.Swagger.Internal.Schema.Validation where
24−
25−import Prelude ()
26−import Prelude.Compat
27−
28−import Control.Applicative
29−import Control.Lens
30−import Control.Monad (when)
31−
32−import Data.Aeson hiding (Result)
33−import Data.Aeson.Encode.Pretty (encodePretty)
34−import Data.Foldable (for_, sequenceA_,
35− traverse_)
36−import Data.HashMap.Strict (HashMap)
37−import qualified Data.HashMap.Strict as HashMap
38−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
39−import qualified "unordered-containers" Data.HashSet as HashSet
40−import Data.Proxy
41−import Data.Scientific (Scientific, isInteger)
42−import Data.Text (Text)
43−import qualified Data.Text as Text
44−import qualified Data.Text.Lazy as TL
45−import qualified Data.Text.Lazy.Encoding as TL
46−import Data.Vector (Vector)
47−import qualified Data.Vector as Vector
48−
49−import Data.Swagger.Declare
50−import Data.Swagger.Internal
51−import Data.Swagger.Internal.Schema
52−import Data.Swagger.Lens
53−
54−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
55−-- This can be used with QuickCheck to ensure those instances are coherent:
56−--
57−-- prop> validateToJSON (x :: Int) == []
58−--
59−-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
60−-- See @'validateToJSONWithPatternChecker'@.
61−--
62−-- See 'renderValidationErrors' on how the output is structured.
63−validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
64−validatePrettyToJSON = renderValidationErrors validateToJSON
65−
66−-- | Variant of 'validatePrettyToJSON' with typed output.
67−validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
68−validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
69−
70−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
71−-- This can be used with QuickCheck to ensure those instances are coherent.
72−--
73−-- For validation without patterns see @'validateToJSON'@. See also:
74−-- 'renderValidationErrors'.
75−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
76−validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
77− where
78− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
79−
80−-- | Pretty print validation errors
81−-- together with actual JSON and Swagger Schema
82−-- (using 'encodePretty').
83−--
84−-- >>> import Data.Aeson as Aeson
85−-- >>> import Data.Foldable (traverse_)
86−-- >>> import GHC.Generics
87−-- >>> data Phone = Phone { value :: String } deriving (Generic)
88−-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)
89−-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]
90−-- >>> instance ToSchema Phone
91−-- >>> instance ToSchema Person
92−-- >>> let person = Person { name = "John", phone = Phone "123456" }
93−-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person
94−-- Validation against the schema fails:
95−-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
96−-- <BLANKLINE>
97−-- JSON value:
98−-- {
99−-- "name": "John"
100−-- }
101−-- <BLANKLINE>
102−-- Swagger Schema:
103−-- {
104−-- "required": [
105−-- "name",
106−-- "phone"
107−-- ],
108−-- "type": "object",
109−-- "properties": {
110−-- "phone": {
111−-- "$ref": "#/definitions/Phone"
112−-- },
113−-- "name": {
114−-- "type": "string"
115−-- }
116−-- }
117−-- }
118−-- <BLANKLINE>
119−-- Swagger Description Context:
120−-- {
121−-- "Phone": {
122−-- "required": [
123−-- "value"
124−-- ],
125−-- "type": "object",
126−-- "properties": {
127−-- "value": {
128−-- "type": "string"
129−-- }
130−-- }
131−-- }
132−-- }
133−-- <BLANKLINE>
134−renderValidationErrors
135− :: forall a. (ToJSON a, ToSchema a)
136− => (a -> [ValidationError]) -> a -> Maybe String
137−renderValidationErrors f x =
138− case f x of
139− [] -> Nothing
140− errors -> Just $ unlines
141− [ "Validation against the schema fails:"
142− , unlines (map (" * " ++) errors)
143− , "JSON value:"
144− , ppJSONString (toJSON x)
145− , ""
146− , "Swagger Schema:"
147− , ppJSONString (toJSON schema_)
148− , ""
149− , "Swagger Description Context:"
150− , ppJSONString (toJSON refs_)
151− ]
152− where
153− ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty
154− (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
155−
156−-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
157−--
158−-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
159−--
160−-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.
161−-- See @'validateJSONWithPatternChecker'@.
162−validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]
163−validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)
164−
165−-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.
166−--
167−-- For validation without patterns see @'validateJSON'@.
168−validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]
169−validateJSONWithPatternChecker checker defs sch js =
170− case runValidation (validateWithSchema js) cfg sch of
171− Failed xs -> xs
172− Passed _ -> mempty
173− where
174− cfg = defaultConfig
175− { configPatternChecker = checker
176− , configDefinitions = defs }
177−
178−-- | Validation error message.
179−type ValidationError = String
180−
181−-- | Validation result type.
182−data Result a
183− = Failed [ValidationError] -- ^ Validation failed with a list of error messages.
184− | Passed a -- ^ Validation passed.
185− deriving (Eq, Show, Functor)
186−
187−instance Applicative Result where
188− pure = Passed
189− Passed f <*> Passed x = Passed (f x)
190− Failed xs <*> Failed ys = Failed (xs <> ys)
191− Failed xs <*> _ = Failed xs
192− _ <*> Failed ys = Failed ys
193−
194−instance Alternative Result where
195− empty = Failed mempty
196− Passed x <|> _ = Passed x
197− _ <|> y = y
198−
199−instance Monad Result where
200− return = pure
201− Passed x >>= f = f x
202− Failed xs >>= _ = Failed xs
203−
204−-- | Validation configuration.
205−data Config = Config
206− { -- | Pattern checker for @'_paramSchemaPattern'@ validation.
207− configPatternChecker :: Pattern -> Text -> Bool
208− -- | Schema definitions in scope to resolve references.
209− , configDefinitions :: Definitions Schema
210− }
211−
212−-- | Default @'Config'@:
213−--
214−-- @
215−-- defaultConfig = 'Config'
216−-- { 'configPatternChecker' = \\_pattern _str -> True
217−-- , 'configDefinitions' = mempty
218−-- }
219−-- @
220−defaultConfig :: Config
221−defaultConfig = Config
222− { configPatternChecker = \_pattern _str -> True
223− , configDefinitions = mempty
224− }
225−
226−-- | Value validation.
227−newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
228− deriving (Functor)
229−
230−instance Applicative (Validation schema) where
231− pure x = Validation (\_ _ -> pure x)
232− Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)
233−
234−instance Alternative (Validation schema) where
235− empty = Validation (\_ _ -> empty)
236− Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)
237−
238−instance Profunctor Validation where
239− dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))
240−
241−instance Choice Validation where
242− left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))
243− right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))
244−
245−instance Monad (Validation s) where
246− return = pure
247− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)
248− (>>) = (*>)
249−
250−withConfig :: (Config -> Validation s a) -> Validation s a
251−withConfig f = Validation (\c -> runValidation (f c) c)
252−
253−withSchema :: (s -> Validation s a) -> Validation s a
254−withSchema f = Validation (\c s -> runValidation (f s) c s)
255−
256−-- | Issue an error message.
257−invalid :: String -> Validation schema a
258−invalid msg = Validation (\_ _ -> Failed [msg])
259−
260−-- | Validation passed.
261−valid :: Validation schema ()
262−valid = pure ()
263−
264−-- | Validate schema's property given a lens into that property
265−-- and property checker.
266−checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
267−checkMissing missing l g = withSchema $ \sch ->
268− case sch ^. l of
269− Nothing -> missing
270− Just x -> g x
271−
272−-- | Validate schema's property given a lens into that property
273−-- and property checker.
274−-- If property is missing in schema, consider it valid.
275−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
276−check = checkMissing valid
277−
278−-- | Validate same value with different schema.
279−sub :: t -> Validation t a -> Validation s a
280−sub = lmap . const
281−
282−-- | Validate same value with a part of the original schema.
283−sub_ :: Getting a s a -> Validation a r -> Validation s r
284−sub_ = lmap . view
285−
286−-- | Validate value against a schema given schema reference and validation function.
287−withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
288−withRef (Reference ref) f = withConfig $ \cfg ->
289− case InsOrdHashMap.lookup ref (configDefinitions cfg) of
290− Nothing -> invalid $ "unknown schema " ++ show ref
291− Just s -> f s
292−
293−validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
294−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)
295−validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
296−
297−-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
298−validateWithSchema :: Value -> Validation Schema ()
299−validateWithSchema value = do
300− validateSchemaType value
301− sub_ paramSchema $ validateEnum value
302−
303−-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.
304−validateWithParamSchema :: Value -> Validation (ParamSchema t) ()
305−validateWithParamSchema value = do
306− validateParamSchemaType value
307− validateEnum value
308−
309−validateInteger :: Scientific -> Validation (ParamSchema t) ()
310−validateInteger n = do
311− when (not (isInteger n)) $
312− invalid ("not an integer")
313− validateNumber n
314−
315−validateNumber :: Scientific -> Validation (ParamSchema t) ()
316−validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do
317− let exMax = Just True == sch ^. exclusiveMaximum
318− exMin = Just True == sch ^. exclusiveMinimum
319−
320− check maximum_ $ \m ->
321− when (if exMax then (n >= m) else (n > m)) $
322− invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")
323−
324− check minimum_ $ \m ->
325− when (if exMin then (n <= m) else (n < m)) $
326− invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")
327−
328− check multipleOf $ \k ->
329− when (not (isInteger (n / k))) $
330− invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)
331−
332−validateString :: Text -> Validation (ParamSchema t) ()
333−validateString s = do
334− check maxLength $ \n ->
335− when (len > fromInteger n) $
336− invalid ("string is too long (length should be <=" ++ show n ++ ")")
337−
338− check minLength $ \n ->
339− when (len < fromInteger n) $
340− invalid ("string is too short (length should be >=" ++ show n ++ ")")
341−
342− check pattern $ \regex -> do
343− withConfig $ \cfg -> do
344− when (not (configPatternChecker cfg regex s)) $
345− invalid ("string does not match pattern " ++ show regex)
346− where
347− len = Text.length s
348−
349−validateArray :: Vector Value -> Validation (ParamSchema t) ()
350−validateArray xs = do
351− check maxItems $ \n ->
352− when (len > fromInteger n) $
353− invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")
354−
355− check minItems $ \n ->
356− when (len < fromInteger n) $
357− invalid ("array is too short (size should be >=" ++ show n ++ ")")
358−
359− check items $ \case
360− SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs
361− SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
362− SwaggerItemsArray itemSchemas -> do
363− when (len /= length itemSchemas) $
364− invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")
365− sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
366−
367− check uniqueItems $ \unique ->
368− when (unique && not allUnique) $
369− invalid ("array is expected to contain unique items, but it does not")
370− where
371− len = Vector.length xs
372− allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
373−
374−validateObject :: HashMap Text Value -> Validation Schema ()
375−validateObject o = withSchema $ \sch ->
376− case sch ^. discriminator of
377− Just pname -> case fromJSON <$> HashMap.lookup pname o of
378− Just (Success ref) -> validateWithSchemaRef ref (Object o)
379− Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
380− Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")
381− Nothing -> do
382− check maxProperties $ \n ->
383− when (size > n) $
384− invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")
385−
386− check minProperties $ \n ->
387− when (size < n) $
388− invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")
389−
390− validateRequired
391− validateProps
392− where
393− size = fromIntegral (HashMap.size o)
394−
395− validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)
396− validateReq n =
397− when (not (HashMap.member n o)) $
398− invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))
399−
400− validateProps = withSchema $ \sch -> do
401− for_ (HashMap.toList o) $ \(k, v) ->
402− case v of
403− Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
404− _ ->
405− case InsOrdHashMap.lookup k (sch ^. properties) of
406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
407− Just s -> validateWithSchemaRef s v
408−
409− validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid
410− validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"
411− validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
412−
413− unknownProperty :: Text -> Validation s a
414− unknownProperty pname = invalid $
415− "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"
416−
417−validateEnum :: Value -> Validation (ParamSchema t) ()
418−validateEnum value = do
419− check enum_ $ \xs ->
420− when (value `notElem` xs) $
421− invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
422−
423−-- | Infer schema type based on used properties.
424−--
425−-- This is like 'inferParamSchemaTypes', but also works for objects:
426−--
427−-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"
428−-- Just [SwaggerObject]
429−inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]
430−inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++
431− [ SwaggerObject | any ($ sch)
432− [ has (additionalProperties._Just)
433− , has (maxProperties._Just)
434− , has (minProperties._Just)
435− , has (properties.folded)
436− , has (required.folded) ] ]
437−
438−-- | Infer schema type based on used properties.
439−--
440−-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"
441−-- Just [SwaggerString]
442−--
443−-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"
444−-- Just [SwaggerArray]
445−--
446−-- From numeric properties 'SwaggerInteger' type is inferred.
447−-- If you want 'SwaggerNumber' instead, you must specify it explicitly.
448−--
449−-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"
450−-- Just [SwaggerInteger]
451−inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]
452−inferParamSchemaTypes sch = concat
453− [ [ SwaggerArray | any ($ sch)
454− [ has (items._Just)
455− , has (maxItems._Just)
456− , has (minItems._Just)
457− , has (uniqueItems._Just) ] ]
458− , [ SwaggerInteger | any ($ sch)
459− [ has (exclusiveMaximum._Just)
460− , has (exclusiveMinimum._Just)
461− , has (maximum_._Just)
462− , has (minimum_._Just)
463− , has (multipleOf._Just) ] ]
464− , [ SwaggerString | any ($ sch)
465− [ has (maxLength._Just)
466− , has (minLength._Just)
467− , has (pattern._Just) ] ]
468− ]
469−
470−validateSchemaType :: Value -> Validation Schema ()
471−validateSchemaType value = withSchema $ \sch ->
472− case (sch ^. type_, value) of
473− (Just SwaggerNull, Null) -> valid
474− (Just SwaggerBoolean, Bool _) -> valid
475− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
476− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
477− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
478− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
479− (Just SwaggerObject, Object o) -> validateObject o
480− (Nothing, Null) -> valid
481− (Nothing, Bool _) -> valid
482− -- Number by default
483− (Nothing, Number n) -> sub_ paramSchema (validateNumber n)
484− (Nothing, String s) -> sub_ paramSchema (validateString s)
485− (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
486− (Nothing, Object o) -> validateObject o
487− bad -> invalid $ "expected JSON value of type " ++ showType bad
488−
489−validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
490−validateParamSchemaType value = withSchema $ \sch ->
491− case (sch ^. type_, value) of
492− (Just SwaggerBoolean, Bool _) -> valid
493− (Just SwaggerInteger, Number n) -> validateInteger n
494− (Just SwaggerNumber, Number n) -> validateNumber n
495− (Just SwaggerString, String s) -> validateString s
496− (Just SwaggerArray, Array xs) -> validateArray xs
497− (Nothing, Bool _) -> valid
498− -- Number by default
499− (Nothing, Number n) -> validateNumber n
500− (Nothing, String s) -> validateString s
501− (Nothing, Array xs) -> validateArray xs
502− bad -> invalid $ "expected JSON value of type " ++ showType bad
503−
504−showType :: (Maybe (SwaggerType t), Value) -> String
505−showType (Just type_, _) = show type_
506−showType (Nothing, Null) = "SwaggerNull"
507−showType (Nothing, Bool _) = "SwaggerBoolean"
508−showType (Nothing, Number _) = "SwaggerNumber"
509−showType (Nothing, String _) = "SwaggerString"
510−showType (Nothing, Array _) = "SwaggerArray"
511−showType (Nothing, Object _) = "SwaggerObject"
src/Data/Swagger/Internal/TypeShape.hsdeleted−66
@@ -1,66 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−
9−module Data.Swagger.Internal.TypeShape where
10−
11−import Data.Proxy
12−import GHC.Generics
13−import GHC.TypeLits
14−import GHC.Exts (Constraint)
15−
16−-- | Shape of a datatype.
17−data TypeShape
18− = Enumeration -- ^ A simple enumeration.
19− | SumOfProducts -- ^ A product or a sum of non-unit products.
20− | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
21−
22−-- | A combined shape for a product type.
23−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
24− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
25− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
26− ProdCombine a b = SumOfProducts
27−
28−-- | A combined shape for a sum type.
29−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
30− SumCombine Enumeration Enumeration = Enumeration
31− SumCombine SumOfProducts SumOfProducts = SumOfProducts
32− SumCombine a b = Mixed
33−
34−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
35− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
36−
37−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
38− GenericHasSimpleShape t f Enumeration = ()
39− GenericHasSimpleShape t f SumOfProducts = ()
40−#if __GLASGOW_HASKELL__ < 800
41− GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t
42−
43−class CannotDeriveSchemaForMixedSumType t where
44−#else
45− GenericHasSimpleShape t f Mixed =
46− TypeError
47− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
48− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
49− :$$: Text "Swagger does not have a good representation for these types."
50− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
51− :$$: Text "that matches aeson's Generic-based toJSON,"
52− :$$: Text "but that's not supported by some Swagger tools."
53− )
54−#endif
55−
56−-- | Infer a 'TypeShape' for a generic representation of a type.
57−type family GenericShape (g :: * -> *) :: TypeShape
58−
59−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
60−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
61−type instance GenericShape (D1 d f) = GenericShape f
62−type instance GenericShape (C1 c U1) = Enumeration
63−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
64−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
65−
66−
src/Data/Swagger/Internal/Utils.hsdeleted−133
@@ -1,133 +0,0 @@
1−{-# LANGUAGE DefaultSignatures #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE TypeOperators #-}
7−module Data.Swagger.Internal.Utils where
8−
9−import Prelude ()
10−import Prelude.Compat
11−
12−import Control.Lens ((&), (%~))
13−import Control.Lens.TH
14−import Data.Aeson
15−import Data.Aeson.Types
16−import Data.Char
17−import Data.Data
18−import Data.Hashable (Hashable)
19−import Data.HashMap.Strict (HashMap)
20−import qualified Data.HashMap.Strict as HashMap
21−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
23−import Data.Map (Map)
24−import Data.Set (Set)
25−import Data.Text (Text)
26−import GHC.Generics
27−import Language.Haskell.TH (mkName)
28−
29−swaggerFieldRules :: LensRules
30−swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
31− where
32− swaggerFieldNamer namer dname fnames fname =
33− map fixDefName (namer dname fnames fname)
34−
35− fixDefName (MethodName cname mname) = MethodName cname (fixName mname)
36− fixDefName (TopName name) = TopName (fixName name)
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
48−
49−gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a
50−gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
51− Just x -> z x
52− Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
53−
54−jsonPrefix :: String -> Options
55−jsonPrefix prefix = defaultOptions
56− { fieldLabelModifier = modifier . drop 1
57− , constructorTagModifier = modifier
58− , sumEncoding = ObjectWithSingleField
59− , omitNothingFields = True
60− }
61− where
62− modifier = lowerFirstUppers . drop (length prefix)
63−
64− lowerFirstUppers s = map toLower x ++ y
65− where (x, y) = span isUpper s
66−
67−parseOneOf :: ToJSON a => [a] -> Value -> Parser a
68−parseOneOf xs js =
69− case lookup js ys of
70− Nothing -> fail $ "invalid json: " ++ show js ++ " (expected one of " ++ show (map fst ys) ++ ")"
71− Just x -> pure x
72− where
73− ys = zip (map toJSON xs) xs
74−
75−(<+>) :: Value -> Value -> Value
76−Object x <+> Object y = Object (x <> y)
77−_ <+> _ = error "<+>: merging non-objects"
78−
79−genericMempty :: (Generic a, GMonoid (Rep a)) => a
80−genericMempty = to gmempty
81−
82−genericMappend :: (Generic a, GMonoid (Rep a)) => a -> a -> a
83−genericMappend x y = to (gmappend (from x) (from y))
84−
85−class GMonoid f where
86− gmempty :: f p
87− gmappend :: f p -> f p -> f p
88−
89−instance GMonoid U1 where
90− gmempty = U1
91− gmappend _ _ = U1
92−
93−instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
94− gmempty = gmempty :*: gmempty
95− gmappend (a :*: x) (b :*: y) = gmappend a b :*: gmappend x y
96−
97−instance SwaggerMonoid a => GMonoid (K1 i a) where
98− gmempty = K1 swaggerMempty
99− gmappend (K1 x) (K1 y) = K1 (swaggerMappend x y)
100−
101−instance GMonoid f => GMonoid (M1 i t f) where
102− gmempty = M1 gmempty
103− gmappend (M1 x) (M1 y) = M1 (gmappend x y)
104−
105−class SwaggerMonoid m where
106− swaggerMempty :: m
107− swaggerMappend :: m -> m -> m
108− default swaggerMempty :: Monoid m => m
109− swaggerMempty = mempty
110− default swaggerMappend :: Monoid m => m -> m -> m
111− swaggerMappend = mappend
112−
113−instance 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)
124−
125−instance SwaggerMonoid Text where
126− swaggerMempty = mempty
127− swaggerMappend x "" = x
128− swaggerMappend _ y = y
129−
130−instance SwaggerMonoid (Maybe a) where
131− swaggerMempty = Nothing
132− swaggerMappend x Nothing = x
133− swaggerMappend _ y = y
src/Data/Swagger/Lens.hsdeleted−186
@@ -1,186 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE RankNTypes #-}
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.
20−module Data.Swagger.Lens where
21−
22−import Control.Lens
23−import Data.Aeson (Value)
24−import Data.Scientific (Scientific)
25−import Data.Swagger.Internal
26−import Data.Swagger.Internal.Utils
27−import Data.Text (Text)
28−
29−-- * Classy lenses
30−
31−makeFields ''Swagger
32−makeFields ''Host
33−makeFields ''Info
34−makeFields ''Contact
35−makeFields ''License
36−makeLensesWith swaggerFieldRules ''PathItem
37−makeFields ''Tag
38−makeFields ''Operation
39−makeFields ''Param
40−makeLensesWith swaggerFieldRules ''ParamOtherSchema
41−makeFields ''Header
42−makeFields ''Schema
43−makeFields ''NamedSchema
44−makeLensesWith swaggerFieldRules ''ParamSchema
45−makeFields ''Xml
46−makeLensesWith swaggerFieldRules ''Responses
47−makeFields ''Response
48−makeLensesWith swaggerFieldRules ''SecurityScheme
49−makeFields ''ApiKeyParams
50−makeFields ''OAuth2Params
51−makeFields ''ExternalDocs
52−
53−-- * Prisms
54−-- ** 'ParamAnySchema' prisms
55−makePrisms ''ParamAnySchema
56−-- ** 'SecuritySchemeType' prisms
57−makePrisms ''SecuritySchemeType
58−-- ** 'Referenced' prisms
59−makePrisms ''Referenced
60−
61−-- ** 'SwaggerItems' prisms
62−
63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]
64−_SwaggerItemsArray
65− = unto (\x -> SwaggerItemsArray x)
66−{- \x -> case x of
67− SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
68− SwaggerItemsObject o -> Left (SwaggerItemsObject o)
69− SwaggerItemsArray a -> Right a
70−-}
71−
72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)
73−_SwaggerItemsObject
74− = unto (\x -> SwaggerItemsObject x)
75−{- \x -> case x of
76− SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
77− SwaggerItemsObject o -> Right o
78− SwaggerItemsArray a -> Left (SwaggerItemsArray a)
79−-}
80−
81−_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
82−_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
83−
84−-- =============================================================
85−-- More helpful instances for easier access to schema properties
86−
87−type instance Index Responses = HttpStatusCode
88−type instance Index Operation = HttpStatusCode
89−
90−type instance IxValue Responses = Referenced Response
91−type instance IxValue Operation = Referenced Response
92−
93−instance Ixed Responses where ix n = responses . ix n
94−instance At Responses where at n = responses . at n
95−
96−instance Ixed Operation where ix n = responses . ix n
97−instance At Operation where at n = responses . at n
98−
99−type instance Index SecurityDefinitions = Text
100−type instance IxValue SecurityDefinitions = SecurityScheme
101−
102−instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n
103−instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n
104−
105−instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
106−
107−-- HasType instances
108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_
109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_
112−
113−-- HasDefault instances
114−instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
115−instance HasDefault Schema (Maybe Value) where default_ = paramSchema.default_
116−instance HasDefault ParamOtherSchema (Maybe Value) where default_ = paramSchema.default_
117−
118−-- OVERLAPPABLE instances
119−
120−instance
121−#if __GLASGOW_HASKELL__ >= 710
122− OVERLAPPABLE_
123−#endif
124− HasParamSchema s (ParamSchema t)
125− => HasFormat s (Maybe Format) where
126− format = paramSchema.format
127−
128−instance
129−#if __GLASGOW_HASKELL__ >= 710
130− OVERLAPPABLE_
131−#endif
132− HasParamSchema s (ParamSchema t)
133− => HasItems s (Maybe (SwaggerItems t)) where
134− items = paramSchema.items
135−
136−instance
137−#if __GLASGOW_HASKELL__ >= 710
138− OVERLAPPABLE_
139−#endif
140− HasParamSchema s (ParamSchema t)
141− => HasMaximum s (Maybe Scientific) where
142− maximum_ = paramSchema.maximum_
143−
144−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
145− => HasExclusiveMaximum s (Maybe Bool) where
146− exclusiveMaximum = paramSchema.exclusiveMaximum
147−
148−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
149− => HasMinimum s (Maybe Scientific) where
150− minimum_ = paramSchema.minimum_
151−
152−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
153− => HasExclusiveMinimum s (Maybe Bool) where
154− exclusiveMinimum = paramSchema.exclusiveMinimum
155−
156−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
157− => HasMaxLength s (Maybe Integer) where
158− maxLength = paramSchema.maxLength
159−
160−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
161− => HasMinLength s (Maybe Integer) where
162− minLength = paramSchema.minLength
163−
164−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
165− => HasPattern s (Maybe Text) where
166− pattern = paramSchema.pattern
167−
168−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
169− => HasMaxItems s (Maybe Integer) where
170− maxItems = paramSchema.maxItems
171−
172−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
173− => HasMinItems s (Maybe Integer) where
174− minItems = paramSchema.minItems
175−
176−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
177− => HasUniqueItems s (Maybe Bool) where
178− uniqueItems = paramSchema.uniqueItems
179−
180−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
181− => HasEnum s (Maybe [Value]) where
182− enum_ = paramSchema.enum_
183−
184−instance OVERLAPPABLE_ HasParamSchema s (ParamSchema t)
185− => HasMultipleOf s (Maybe Scientific) where
186− multipleOf = paramSchema.multipleOf
src/Data/Swagger/Operation.hsdeleted−193
@@ -1,193 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−-- |
3−-- Module: Data.Swagger.Operation
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7−-- Helper traversals and functions for Swagger operations manipulations.
8−-- These might be useful when you already have Swagger specification
9−-- generated by something else.
10−module Data.Swagger.Operation (
11− -- * Operation traversals
12− allOperations,
13− operationsOf,
14−
15− -- * Manipulation
16− -- ** Tags
17− applyTags,
18− applyTagsFor,
19−
20− -- ** Responses
21− setResponse,
22− setResponseWith,
23− setResponseFor,
24− setResponseForWith,
25−
26− -- ** Paths
27− prependPath,
28−
29− -- * Miscellaneous
30− declareResponse,
31−) where
32−
33−import Prelude ()
34−import Prelude.Compat
35−
36−import Control.Lens
37−import Data.Data.Lens
38−import Data.List.Compat
39−import Data.Maybe (mapMaybe)
40−import Data.Proxy
41−import qualified Data.Set as Set
42−
43−import Data.Swagger.Declare
44−import Data.Swagger.Internal
45−import Data.Swagger.Lens
46−import Data.Swagger.Schema
47−
48−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49−import qualified Data.HashSet.InsOrd as InsOrdHS
50−
51−-- $setup
52−-- >>> import Data.Aeson
53−-- >>> import Data.Proxy
54−-- >>> import Data.Time
55−
56−-- | Prepend path piece to all operations of the spec.
57−-- Leading and trailing slashes are trimmed/added automatically.
58−--
59−-- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)]
60−-- >>> encode $ prependPath "user/{user_id}" api ^. paths
61−-- "{\"/user/{user_id}/info\":{}}"
62−prependPath :: FilePath -> Swagger -> Swagger
63−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
64− where
65− x </> y = case trim y of
66− "" -> "/" <> trim x
67− y' -> "/" <> trim x <> "/" <> y'
68−
69− trim = dropWhile (== '/') . dropWhileEnd (== '/')
70−
71−-- | All operations of a Swagger spec.
72−allOperations :: Traversal' Swagger Operation
73−allOperations = paths.traverse.template
74−
75−-- | @'operationsOf' sub@ will traverse only those operations
76−-- that are present in @sub@. Note that @'Operation'@ is determined
77−-- by both path and method.
78−--
79−-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
80−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
81−-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
82−-- >>> encode api
83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
84−-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
85−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
86−operationsOf :: Swagger -> Traversal' Swagger Operation
87−operationsOf sub = paths.itraversed.withIndex.subops
88− where
89− -- | Traverse operations that correspond to paths and methods of the sub API.
90− subops :: Traversal' (FilePath, PathItem) Operation
91− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of
92− Just subitem -> (,) path <$> methodsOf subitem f item
93− Nothing -> pure (path, item)
94−
95− -- | Traverse operations that exist in a given @'PathItem'@
96− -- This is used to traverse only the operations that exist in sub API.
97− methodsOf :: PathItem -> Traversal' PathItem Operation
98− methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just
99− where
100− ops = pathItem ^.. template :: [Maybe Operation]
101− ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops
102−
103−-- | Apply tags to all operations and update the global list of tags.
104−--
105−-- @
106−-- 'applyTags' = 'applyTagsFor' 'allOperations'
107−-- @
108−applyTags :: [Tag] -> Swagger -> Swagger
109−applyTags = applyTagsFor allOperations
110−
111−-- | Apply tags to a part of Swagger spec and update the global
112−-- list of tags.
113−applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
114−applyTagsFor ops ts swag = swag
115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
116− & tags %~ (<> InsOrdHS.fromList ts)
117−
118−-- | Construct a response with @'Schema'@ while declaring all
119−-- necessary schema definitions.
120−--
121−-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122−-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
123−declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response
124−declareResponse proxy = do
125− s <- declareSchemaRef proxy
126− return (mempty & schema ?~ s)
127−
128−-- | Set response for all operations.
129−-- This will also update global schema definitions.
130−--
131−-- If the response already exists it will be overwritten.
132−--
133−-- @
134−-- 'setResponse' = 'setResponseFor' 'allOperations'
135−-- @
136−--
137−-- Example:
138−--
139−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
140−-- >>> let res = declareResponse (Proxy :: Proxy Day)
141−-- >>> encode $ api & setResponse 200 res
142−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"
143−--
144−-- See also @'setResponseWith'@.
145−setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
146−setResponse = setResponseFor allOperations
147−
148−-- | Set or update response for all operations.
149−-- This will also update global schema definitions.
150−--
151−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
152−-- then just the new response is used.
153−--
154−-- @
155−-- 'setResponseWith' = 'setResponseForWith' 'allOperations'
156−-- @
157−--
158−-- See also @'setResponse'@.
159−setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
160−setResponseWith = setResponseForWith allOperations
161−
162−-- | Set response for specified operations.
163−-- This will also update global schema definitions.
164−--
165−-- If the response already exists it will be overwritten.
166−--
167−-- See also @'setResponseForWith'@.
168−setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
169−setResponseFor ops code dres swag = swag
170− & definitions %~ (<> defs)
171− & ops . at code ?~ Inline res
172− where
173− (defs, res) = runDeclare dres mempty
174−
175−-- | Set or update response for specified operations.
176−-- This will also update global schema definitions.
177−--
178−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
179−-- then just the new response is used.
180−--
181−-- See also @'setResponseFor'@.
182−setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
183−setResponseForWith ops f code dres swag = swag
184− & definitions %~ (<> defs)
185− & ops . at code %~ Just . Inline . combine
186− where
187− (defs, new) = runDeclare dres mempty
188−
189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of
190− Just old -> f old new
191− Nothing -> new -- response name can't be dereferenced, replacing with new response
192− combine (Just (Inline old)) = f old new
193− combine Nothing = new
src/Data/Swagger/Optics.hsdeleted−597
@@ -1,597 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE OverloadedLabels #-}
5−{-# LANGUAGE TemplateHaskell #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -fno-warn-orphans #-}
9−-- |
10−-- Module: Data.Swagger.Optics
11−-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>
12−-- Stability: experimental
13−--
14−-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>
15−-- library.
16−--
17−-- >>> import Data.Aeson
18−-- >>> import Optics.Core
19−-- >>> :set -XOverloadedLabels
20−--
21−-- Example from the "Data.Swagger" module using @optics@:
22−--
23−-- >>> :{
24−-- encode $ (mempty :: Swagger)
25−-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]
26−-- & #paths .~
27−-- [ ("/user", mempty & #get ?~ (mempty
28−-- & #produces ?~ MimeList ["application/json"]
29−-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))
30−-- & at 404 ?~ "User info not found")) ]
31−-- :}
32−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
33−--
34−-- For convenience optics are defined as /labels/. It means that field accessor
35−-- names can be overloaded for different types. One such common field is
36−-- @#description@. Many components of a Swagger specification can have
37−-- descriptions, and you can use the same name for them:
38−--
39−-- >>> encode $ (mempty :: Response) & #description .~ "No content"
40−-- "{\"description\":\"No content\"}"
41−-- >>> :{
42−-- encode $ (mempty :: Schema)
43−-- & #type ?~ SwaggerBoolean
44−-- & #description ?~ "To be or not to be"
45−-- :}
46−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
47−--
48−-- @'ParamSchema'@ is basically the /base schema specification/ and many types
49−-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively
50−-- made fields of the type that has it. For example, you can use @#type@ to
51−-- access @'SwaggerType'@ of @'Header'@ schema without having to use
52−-- @#paramSchema@:
53−--
54−-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber
55−-- "{\"type\":\"number\"}"
56−--
57−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
58−-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
59−--
60−-- >>> :{
61−-- encode $ (mempty :: Operation)
62−-- & at 404 ?~ "Not found"
63−-- :}
64−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
65−--
66−module Data.Swagger.Optics () where
67−
68−import Data.Aeson (Value)
69−import Data.Scientific (Scientific)
70−import Data.Swagger.Internal
71−import Data.Text (Text)
72−import Optics.Core
73−import Optics.TH
74−
75−-- Lenses
76−
77−makeFieldLabels ''Swagger
78−makeFieldLabels ''Host
79−makeFieldLabels ''Info
80−makeFieldLabels ''Contact
81−makeFieldLabels ''License
82−makeFieldLabels ''PathItem
83−makeFieldLabels ''Tag
84−makeFieldLabels ''Operation
85−makeFieldLabels ''Param
86−makeFieldLabels ''ParamOtherSchema
87−makeFieldLabels ''Header
88−makeFieldLabels ''Schema
89−makeFieldLabels ''NamedSchema
90−makeFieldLabels ''ParamSchema
91−makeFieldLabels ''Xml
92−makeFieldLabels ''Responses
93−makeFieldLabels ''Response
94−makeFieldLabels ''SecurityScheme
95−makeFieldLabels ''ApiKeyParams
96−makeFieldLabels ''OAuth2Params
97−makeFieldLabels ''ExternalDocs
98−
99−-- Prisms
100−
101−makePrismLabels ''ParamAnySchema
102−makePrismLabels ''SecuritySchemeType
103−makePrismLabels ''Referenced
104−
105−-- SwaggerItems prisms
106−
107−instance
108− ( a ~ [Referenced Schema]
109− , b ~ [Referenced Schema]
110− ) => LabelOptic "_SwaggerItemsArray"
111− A_Review
112− (SwaggerItems 'SwaggerKindSchema)
113− (SwaggerItems 'SwaggerKindSchema)
114− a
115− b where
116− labelOptic = unto (\x -> SwaggerItemsArray x)
117− {-# INLINE labelOptic #-}
118−
119−instance
120− ( a ~ Referenced Schema
121− , b ~ Referenced Schema
122− ) => LabelOptic "_SwaggerItemsObject"
123− A_Review
124− (SwaggerItems 'SwaggerKindSchema)
125− (SwaggerItems 'SwaggerKindSchema)
126− a
127− b where
128− labelOptic = unto (\x -> SwaggerItemsObject x)
129− {-# INLINE labelOptic #-}
130−
131−instance
132− ( a ~ (Maybe (CollectionFormat t), ParamSchema t)
133− , b ~ (Maybe (CollectionFormat t), ParamSchema t)
134− ) => LabelOptic "_SwaggerItemsPrimitive"
135− A_Review
136− (SwaggerItems t)
137− (SwaggerItems t)
138− a
139− b where
140− labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)
141− {-# INLINE labelOptic #-}
142−
143−-- =============================================================
144−-- More helpful instances for easier access to schema properties
145−
146−type instance Index Responses = HttpStatusCode
147−type instance Index Operation = HttpStatusCode
148−
149−type instance IxValue Responses = Referenced Response
150−type instance IxValue Operation = Referenced Response
151−
152−instance Ixed Responses where
153− ix n = #responses % ix n
154− {-# INLINE ix #-}
155−instance At Responses where
156− at n = #responses % at n
157− {-# INLINE at #-}
158−
159−instance Ixed Operation where
160− ix n = #responses % ix n
161− {-# INLINE ix #-}
162−instance At Operation where
163− at n = #responses % at n
164− {-# INLINE at #-}
165−
166−-- #paramSchema
167−
168−instance
169− ( a ~ ParamSchema 'SwaggerKindSchema
170− , b ~ ParamSchema 'SwaggerKindSchema
171− ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where
172− labelOptic = #schema % #paramSchema
173− {-# INLINE labelOptic #-}
174−
175−-- #type
176−
177−instance
178− ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
179− , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
180− ) => LabelOptic "type" A_Lens Header Header a b where
181− labelOptic = #paramSchema % #type
182− {-# INLINE labelOptic #-}
183−
184−instance
185− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
186− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
187− ) => LabelOptic "type" A_Lens Schema Schema a b where
188− labelOptic = #paramSchema % #type
189− {-# INLINE labelOptic #-}
190−
191−instance
192− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
193− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
194− ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
195− labelOptic = #paramSchema % #type
196− {-# INLINE labelOptic #-}
197−
198−instance
199− ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
200− , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
201− ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where
202− labelOptic = #paramSchema % #type
203− {-# INLINE labelOptic #-}
204−
205−-- #default
206−
207−instance
208− ( a ~ Maybe Value, b ~ Maybe Value
209− ) => LabelOptic "default" A_Lens Header Header a b where
210− labelOptic = #paramSchema % #default
211− {-# INLINE labelOptic #-}
212−
213−instance
214− ( a ~ Maybe Value, b ~ Maybe Value
215− ) => LabelOptic "default" A_Lens Schema Schema a b where
216− labelOptic = #paramSchema % #default
217− {-# INLINE labelOptic #-}
218−
219−instance
220− ( a ~ Maybe Value, b ~ Maybe Value
221− ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where
222− labelOptic = #paramSchema % #default
223− {-# INLINE labelOptic #-}
224−
225−instance
226− ( a ~ Maybe Value, b ~ Maybe Value
227− ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where
228− labelOptic = #paramSchema % #default
229− {-# INLINE labelOptic #-}
230−
231−-- #format
232−
233−instance
234− ( a ~ Maybe Format, b ~ Maybe Format
235− ) => LabelOptic "format" A_Lens Header Header a b where
236− labelOptic = #paramSchema % #format
237− {-# INLINE labelOptic #-}
238−
239−instance
240− ( a ~ Maybe Format, b ~ Maybe Format
241− ) => LabelOptic "format" A_Lens Schema Schema a b where
242− labelOptic = #paramSchema % #format
243− {-# INLINE labelOptic #-}
244−
245−instance
246− ( a ~ Maybe Format, b ~ Maybe Format
247− ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where
248− labelOptic = #paramSchema % #format
249− {-# INLINE labelOptic #-}
250−
251−instance
252− ( a ~ Maybe Format, b ~ Maybe Format
253− ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where
254− labelOptic = #paramSchema % #format
255− {-# INLINE labelOptic #-}
256−
257−-- #items
258−
259−instance
260− ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
261− , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
262− ) => LabelOptic "items" A_Lens Header Header a b where
263− labelOptic = #paramSchema % #items
264− {-# INLINE labelOptic #-}
265−
266−instance
267− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
268− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
269− ) => LabelOptic "items" A_Lens Schema Schema a b where
270− labelOptic = #paramSchema % #items
271− {-# INLINE labelOptic #-}
272−
273−instance
274− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
275− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
276− ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
277− labelOptic = #paramSchema % #items
278− {-# INLINE labelOptic #-}
279−
280−instance
281− ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
282− , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
283− ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where
284− labelOptic = #paramSchema % #items
285− {-# INLINE labelOptic #-}
286−
287−-- #maximum
288−
289−instance
290− ( a ~ Maybe Scientific, b ~ Maybe Scientific
291− ) => LabelOptic "maximum" A_Lens Header Header a b where
292− labelOptic = #paramSchema % #maximum
293− {-# INLINE labelOptic #-}
294−
295−instance
296− ( a ~ Maybe Scientific, b ~ Maybe Scientific
297− ) => LabelOptic "maximum" A_Lens Schema Schema a b where
298− labelOptic = #paramSchema % #maximum
299− {-# INLINE labelOptic #-}
300−
301−instance
302− ( a ~ Maybe Scientific, b ~ Maybe Scientific
303− ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where
304− labelOptic = #paramSchema % #maximum
305− {-# INLINE labelOptic #-}
306−
307−instance
308− ( a ~ Maybe Scientific, b ~ Maybe Scientific
309− ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
310− labelOptic = #paramSchema % #maximum
311− {-# INLINE labelOptic #-}
312−
313−-- #exclusiveMaximum
314−
315−instance
316− ( a ~ Maybe Bool, b ~ Maybe Bool
317− ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where
318− labelOptic = #paramSchema % #exclusiveMaximum
319− {-# INLINE labelOptic #-}
320−
321−instance
322− ( a ~ Maybe Bool, b ~ Maybe Bool
323− ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where
324− labelOptic = #paramSchema % #exclusiveMaximum
325− {-# INLINE labelOptic #-}
326−
327−instance
328− ( a ~ Maybe Bool, b ~ Maybe Bool
329− ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where
330− labelOptic = #paramSchema % #exclusiveMaximum
331− {-# INLINE labelOptic #-}
332−
333−instance
334− ( a ~ Maybe Bool, b ~ Maybe Bool
335− ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
336− labelOptic = #paramSchema % #exclusiveMaximum
337− {-# INLINE labelOptic #-}
338−
339−-- #minimum
340−
341−instance
342− ( a ~ Maybe Scientific, b ~ Maybe Scientific
343− ) => LabelOptic "minimum" A_Lens Header Header a b where
344− labelOptic = #paramSchema % #minimum
345− {-# INLINE labelOptic #-}
346−
347−instance
348− ( a ~ Maybe Scientific, b ~ Maybe Scientific
349− ) => LabelOptic "minimum" A_Lens Schema Schema a b where
350− labelOptic = #paramSchema % #minimum
351− {-# INLINE labelOptic #-}
352−
353−instance
354− ( a ~ Maybe Scientific, b ~ Maybe Scientific
355− ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where
356− labelOptic = #paramSchema % #minimum
357− {-# INLINE labelOptic #-}
358−
359−instance
360− ( a ~ Maybe Scientific, b ~ Maybe Scientific
361− ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
362− labelOptic = #paramSchema % #minimum
363− {-# INLINE labelOptic #-}
364−
365−-- #exclusiveMinimum
366−
367−instance
368− ( a ~ Maybe Bool, b ~ Maybe Bool
369− ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where
370− labelOptic = #paramSchema % #exclusiveMinimum
371− {-# INLINE labelOptic #-}
372−
373−instance
374− ( a ~ Maybe Bool, b ~ Maybe Bool
375− ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where
376− labelOptic = #paramSchema % #exclusiveMinimum
377− {-# INLINE labelOptic #-}
378−
379−instance
380− ( a ~ Maybe Bool, b ~ Maybe Bool
381− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where
382− labelOptic = #paramSchema % #exclusiveMinimum
383− {-# INLINE labelOptic #-}
384−
385−instance
386− ( a ~ Maybe Bool, b ~ Maybe Bool
387− ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
388− labelOptic = #paramSchema % #exclusiveMinimum
389− {-# INLINE labelOptic #-}
390−
391−-- #maxLength
392−
393−instance
394− ( a ~ Maybe Integer, b ~ Maybe Integer
395− ) => LabelOptic "maxLength" A_Lens Header Header a b where
396− labelOptic = #paramSchema % #maxLength
397− {-# INLINE labelOptic #-}
398−
399−instance
400− ( a ~ Maybe Integer, b ~ Maybe Integer
401− ) => LabelOptic "maxLength" A_Lens Schema Schema a b where
402− labelOptic = #paramSchema % #maxLength
403− {-# INLINE labelOptic #-}
404−
405−instance
406− ( a ~ Maybe Integer, b ~ Maybe Integer
407− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where
408− labelOptic = #paramSchema % #maxLength
409− {-# INLINE labelOptic #-}
410−
411−instance
412− ( a ~ Maybe Integer, b ~ Maybe Integer
413− ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
414− labelOptic = #paramSchema % #maxLength
415− {-# INLINE labelOptic #-}
416−
417−-- #minLength
418−
419−instance
420− ( a ~ Maybe Integer, b ~ Maybe Integer
421− ) => LabelOptic "minLength" A_Lens Header Header a b where
422− labelOptic = #paramSchema % #minLength
423− {-# INLINE labelOptic #-}
424−
425−instance
426− ( a ~ Maybe Integer, b ~ Maybe Integer
427− ) => LabelOptic "minLength" A_Lens Schema Schema a b where
428− labelOptic = #paramSchema % #minLength
429− {-# INLINE labelOptic #-}
430−
431−instance
432− ( a ~ Maybe Integer, b ~ Maybe Integer
433− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where
434− labelOptic = #paramSchema % #minLength
435− {-# INLINE labelOptic #-}
436−
437−instance
438− ( a ~ Maybe Integer, b ~ Maybe Integer
439− ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
440− labelOptic = #paramSchema % #minLength
441− {-# INLINE labelOptic #-}
442−
443−-- #pattern
444−
445−instance
446− ( a ~ Maybe Text, b ~ Maybe Text
447− ) => LabelOptic "pattern" A_Lens Header Header a b where
448− labelOptic = #paramSchema % #pattern
449− {-# INLINE labelOptic #-}
450−
451−instance
452− ( a ~ Maybe Text, b ~ Maybe Text
453− ) => LabelOptic "pattern" A_Lens Schema Schema a b where
454− labelOptic = #paramSchema % #pattern
455− {-# INLINE labelOptic #-}
456−
457−instance
458− ( a ~ Maybe Text, b ~ Maybe Text
459− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where
460− labelOptic = #paramSchema % #pattern
461− {-# INLINE labelOptic #-}
462−
463−instance
464− ( a ~ Maybe Text, b ~ Maybe Text
465− ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where
466− labelOptic = #paramSchema % #pattern
467− {-# INLINE labelOptic #-}
468−
469−-- #maxItems
470−
471−instance
472− ( a ~ Maybe Integer, b ~ Maybe Integer
473− ) => LabelOptic "maxItems" A_Lens Header Header a b where
474− labelOptic = #paramSchema % #maxItems
475− {-# INLINE labelOptic #-}
476−
477−instance
478− ( a ~ Maybe Integer, b ~ Maybe Integer
479− ) => LabelOptic "maxItems" A_Lens Schema Schema a b where
480− labelOptic = #paramSchema % #maxItems
481− {-# INLINE labelOptic #-}
482−
483−instance
484− ( a ~ Maybe Integer, b ~ Maybe Integer
485− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where
486− labelOptic = #paramSchema % #maxItems
487− {-# INLINE labelOptic #-}
488−
489−instance
490− ( a ~ Maybe Integer, b ~ Maybe Integer
491− ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
492− labelOptic = #paramSchema % #maxItems
493− {-# INLINE labelOptic #-}
494−
495−-- #minItems
496−
497−instance
498− ( a ~ Maybe Integer, b ~ Maybe Integer
499− ) => LabelOptic "minItems" A_Lens Header Header a b where
500− labelOptic = #paramSchema % #minItems
501− {-# INLINE labelOptic #-}
502−
503−instance
504− ( a ~ Maybe Integer, b ~ Maybe Integer
505− ) => LabelOptic "minItems" A_Lens Schema Schema a b where
506− labelOptic = #paramSchema % #minItems
507− {-# INLINE labelOptic #-}
508−
509−instance
510− ( a ~ Maybe Integer, b ~ Maybe Integer
511− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where
512− labelOptic = #paramSchema % #minItems
513− {-# INLINE labelOptic #-}
514−
515−instance
516− ( a ~ Maybe Integer, b ~ Maybe Integer
517− ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
518− labelOptic = #paramSchema % #minItems
519− {-# INLINE labelOptic #-}
520−
521−-- #uniqueItems
522−
523−instance
524− ( a ~ Maybe Bool, b ~ Maybe Bool
525− ) => LabelOptic "uniqueItems" A_Lens Header Header a b where
526− labelOptic = #paramSchema % #uniqueItems
527− {-# INLINE labelOptic #-}
528−
529−instance
530− ( a ~ Maybe Bool, b ~ Maybe Bool
531− ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where
532− labelOptic = #paramSchema % #uniqueItems
533− {-# INLINE labelOptic #-}
534−
535−instance
536− ( a ~ Maybe Bool, b ~ Maybe Bool
537− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where
538− labelOptic = #paramSchema % #uniqueItems
539− {-# INLINE labelOptic #-}
540−
541−instance
542− ( a ~ Maybe Bool, b ~ Maybe Bool
543− ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
544− labelOptic = #paramSchema % #uniqueItems
545− {-# INLINE labelOptic #-}
546−
547−-- #enum
548−
549−instance
550− ( a ~ Maybe [Value], b ~ Maybe [Value]
551− ) => LabelOptic "enum" A_Lens Header Header a b where
552− labelOptic = #paramSchema % #enum
553− {-# INLINE labelOptic #-}
554−
555−instance
556− ( a ~ Maybe [Value], b ~ Maybe [Value]
557− ) => LabelOptic "enum" A_Lens Schema Schema a b where
558− labelOptic = #paramSchema % #enum
559− {-# INLINE labelOptic #-}
560−
561−instance
562− ( a ~ Maybe [Value], b ~ Maybe [Value]
563− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where
564− labelOptic = #paramSchema % #enum
565− {-# INLINE labelOptic #-}
566−
567−instance
568− ( a ~ Maybe [Value], b ~ Maybe [Value]
569− ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where
570− labelOptic = #paramSchema % #enum
571− {-# INLINE labelOptic #-}
572−
573−-- #multipleOf
574−
575−instance
576− ( a ~ Maybe Scientific, b ~ Maybe Scientific
577− ) => LabelOptic "multipleOf" A_Lens Header Header a b where
578− labelOptic = #paramSchema % #multipleOf
579− {-# INLINE labelOptic #-}
580−
581−instance
582− ( a ~ Maybe Scientific, b ~ Maybe Scientific
583− ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where
584− labelOptic = #paramSchema % #multipleOf
585− {-# INLINE labelOptic #-}
586−
587−instance
588− ( a ~ Maybe Scientific, b ~ Maybe Scientific
589− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where
590− labelOptic = #paramSchema % #multipleOf
591− {-# INLINE labelOptic #-}
592−
593−instance
594− ( a ~ Maybe Scientific, b ~ Maybe Scientific
595− ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where
596− labelOptic = #paramSchema % #multipleOf
597− {-# INLINE labelOptic #-}
src/Data/Swagger/ParamSchema.hsdeleted−26
@@ -1,26 +0,0 @@
1−-- |
2−-- Module: Data.Swagger.ParamSchema
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Types and functions for working with Swagger parameter schema.
7−module Data.Swagger.ParamSchema (
8− -- * Encoding
9− ToParamSchema(..),
10−
11− -- * Generic schema encoding
12− genericToParamSchema,
13− toParamSchemaBoundedIntegral,
14−
15− -- * Schema templates
16− passwordParamSchema,
17− binaryParamSchema,
18− byteParamSchema,
19−
20− -- * Generic encoding configuration
21− SchemaOptions(..),
22− defaultSchemaOptions,
23−) where
24−
25−import Data.Swagger.Internal.ParamSchema
26−import Data.Swagger.SchemaOptions
src/Data/Swagger/Schema.hsdeleted−61
@@ -1,61 +0,0 @@
1−-- |
2−-- Module: Data.Swagger.Schema
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Types and functions for working with Swagger schema.
7−module Data.Swagger.Schema (
8− -- * Encoding
9− ToSchema(..),
10− declareSchema,
11− declareSchemaRef,
12− toSchema,
13− toSchemaRef,
14− schemaName,
15− toInlinedSchema,
16−
17− -- * Generic schema encoding
18− genericDeclareNamedSchema,
19− genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
24− genericToNamedSchemaBoundedIntegral,
25− toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
32− paramSchemaToNamedSchema,
33− paramSchemaToSchema,
34−
35− -- ** Unrestricted versions
36− genericDeclareNamedSchemaUnrestricted,
37− genericDeclareSchemaUnrestricted,
38−
39− -- * Schema templates
40− passwordSchema,
41− binarySchema,
42− byteSchema,
43−
44− -- * Sketching @'Schema'@s using @'ToJSON'@
45− sketchSchema,
46− sketchStrictSchema,
47−
48− -- * Inlining @'Schema'@s
49− inlineNonRecursiveSchemas,
50− inlineAllSchemas,
51− inlineSchemas,
52− inlineSchemasWhen,
53−
54− -- * Generic encoding configuration
55− SchemaOptions(..),
56− defaultSchemaOptions,
57− fromAesonOptions,
58−) where
59−
60−import Data.Swagger.Internal.Schema
61−import Data.Swagger.SchemaOptions
src/Data/Swagger/Schema/Generator.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.Schema.Generator where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens.Operators
11−import Control.Monad (filterM)
12−import Data.Aeson
13−import Data.Aeson.Types
14−import qualified Data.HashMap.Strict.InsOrd as M
15−import Data.Maybe
16−import Data.Maybe
17−import Data.Proxy
18−import Data.Scientific
19−import qualified Data.Set as S
20−import Data.Swagger
21−import Data.Swagger.Declare
22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)
23−import qualified Data.Text as T
24−import qualified Data.Vector as V
25−import Test.QuickCheck (arbitrary)
26−import Test.QuickCheck.Gen
27−import Test.QuickCheck.Property
28−
29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30−-- and cannot be inferred.
31−schemaGen :: Definitions Schema -> Schema -> Gen Value
32−schemaGen _ schema
33− | Just cases <- schema ^. paramSchema . enum_ = elements cases
34−schemaGen defns schema =
35− case schema ^. type_ of
36− Nothing ->
37− case inferSchemaTypes schema of
38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
39− -- Gen is not MonadFail
40− _ -> error "unable to infer schema type"
41− Just SwaggerBoolean -> Bool <$> elements [True, False]
42− Just SwaggerNull -> pure Null
43− Just SwaggerNumber
44− | Just min <- schema ^. minimum_
45− , Just max <- schema ^. maximum_ ->
46− Number . fromFloatDigits <$>
47− choose (toRealFloat min, toRealFloat max :: Double)
48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
49− Just SwaggerInteger
50− | Just min <- schema ^. minimum_
51− , Just max <- schema ^. maximum_ ->
52− Number . fromInteger <$>
53− choose (truncate min, truncate max)
54− | otherwise -> Number . fromInteger <$> arbitrary
55− Just SwaggerArray
56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
57− | Just items <- schema ^. items ->
58− case items of
59− SwaggerItemsObject ref -> do
60− size <- getSize
61− let itemSchema = dereference defns ref
62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
64− arrayLength <- choose (minLength', max minLength' maxLength')
65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
66− return . Array $ V.fromList generatedArray
67− SwaggerItemsArray refs ->
68− let itemGens = schemaGen defns . dereference defns <$> refs
69− in fmap (Array . V.fromList) $ sequence itemGens
70− Just SwaggerString -> do
71− size <- getSize
72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
74− length <- choose (minLength', max minLength' maxLength')
75− str <- vectorOf length arbitrary
76− return . String $ T.pack str
77− Just SwaggerObject -> do
78− size <- getSize
79− let props = dereference defns <$> schema ^. properties
80− reqKeys = S.fromList $ schema ^. required
81− allKeys = S.fromList . M.keys $ schema ^. properties
82− optionalKeys = allKeys S.\\ reqKeys
83− minProps' = fromMaybe (length reqKeys) $
84− fromInteger <$> schema ^. minProperties
85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
86− shuffledOptional <- shuffle $ S.toList optionalKeys
87− numProps <- choose (minProps', max minProps' maxProps')
88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
90− let gens = schemaGen defns <$> presentProps
91− additionalGens <- case schema ^. additionalProperties of
92− Just (AdditionalPropertiesSchema addlSchema) -> do
93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
95− _ -> return []
96− x <- sequence $ gens <> additionalGens
97− return . Object $ M.toHashMap x
98− where
99− dereference :: Definitions a -> Referenced a -> a
100− dereference _ (Inline a) = a
101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
102−
103−genValue :: (ToSchema a) => Proxy a -> Gen Value
104−genValue p =
105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
106− in schemaGen defs schema
107−
108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
109−validateFromJSON p = forAll (genValue p) $
110− \val -> case parseEither parseJSON val of
111− Right (_ :: a) -> succeeded
112− Left err -> failed
113− { reason = err
114− }
src/Data/Swagger/Schema/Validation.hsdeleted−90
@@ -1,90 +0,0 @@
1−-- |
2−-- Module: Data.Swagger.Schema.Validation
3−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
4−-- Stability: experimental
5−--
6−-- Validate JSON values with Swagger Schema.
7−module Data.Swagger.Schema.Validation (
8− -- * How to use validation
9− -- $howto
10−
11− -- ** Examples
12− -- $examples
13−
14− -- ** Validating @'Maybe'@
15− -- $maybe
16−
17− -- * JSON validation
18−
19− ValidationError,
20−
21− -- ** Using 'ToJSON' and 'ToSchema'
22− validatePrettyToJSON,
23− validateToJSON,
24− validateToJSONWithPatternChecker,
25− renderValidationErrors,
26−
27− -- ** Using 'Value' and 'Schema'
28− validateJSON,
29− validateJSONWithPatternChecker,
30−) where
31−
32−import Data.Swagger.Internal.Schema.Validation
33−
34−-- $setup
35−-- >>> import Control.Lens
36−-- >>> import Data.Aeson
37−-- >>> import Data.Proxy
38−-- >>> import Data.Swagger
39−-- >>> import GHC.Generics
40−-- >>> :set -XDeriveGeneric
41−
42−-- $howto
43−--
44−-- This module provides helpful functions for JSON validation.
45−-- These functions are meant to be used in test suites for your application
46−-- to ensure that JSON respresentation for your data corresponds to
47−-- schemas you're using for the Swagger specification.
48−--
49−-- It is recommended to use validation functions as QuickCheck properties
50−-- (see <http://hackage.haskell.org/package/QuickCheck>).
51−
52−-- $examples
53−--
54−-- >>> validateToJSON "hello"
55−-- []
56−--
57−-- >>> validateToJSON False
58−-- []
59−--
60−-- >>> newtype Nat = Nat Integer deriving Generic
61−-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n
62−-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0
63−-- >>> validateToJSON (Nat 10)
64−-- []
65−-- >>> validateToJSON (Nat (-5))
66−-- ["value -5.0 falls below minimum (should be >=0.0)"]
67−
68−-- $maybe
69−--
70−-- Because @'Maybe' a@ has the same schema as @a@, validation
71−-- generally fails for @null@ JSON:
72−--
73−-- >>> validateToJSON (Nothing :: Maybe String)
74−-- ["expected JSON value of type SwaggerString"]
75−-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
76−-- ["expected JSON value of type SwaggerString"]
77−-- >>> validateToJSON (123, Nothing :: Maybe String)
78−-- ["expected JSON value of type SwaggerString"]
79−--
80−-- However, when @'Maybe' a@ is a type of a record field,
81−-- validation takes @'required'@ property of the @'Schema'@
82−-- into account:
83−--
84−-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic
85−-- >>> instance ToJSON Person
86−-- >>> instance ToSchema Person
87−-- >>> validateToJSON (Person "Nick" (Just 24))
88−-- []
89−-- >>> validateToJSON (Person "Nick" Nothing)
90−-- []
src/Data/Swagger/SchemaOptions.hsdeleted−72
@@ -1,72 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−-- |
3−-- Module: Data.Swagger.SchemaOptions
4−-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
5−-- Stability: experimental
6−--
7−-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
8−module Data.Swagger.SchemaOptions where
9−
10−import qualified Data.Aeson.Types as Aeson
11−
12−-- | Options that specify how to encode your type to Swagger schema.
13−data SchemaOptions = SchemaOptions
14− { -- | Function applied to field labels. Handy for removing common record prefixes for example.
15− fieldLabelModifier :: String -> String
16− -- | Function applied to constructor tags which could be handy for lower-casing them for example.
17− , constructorTagModifier :: String -> String
18− -- | Function applied to datatype name.
19− , datatypeNameModifier :: String -> String
20− -- | If @'True'@ the constructors of a datatype, with all nullary constructors,
21− -- will be encoded to a string enumeration schema with the constructor tags as possible values.
22− , allNullaryToStringTag :: Bool
23− -- | Hide the field name when a record constructor has only one field, like a newtype.
24− , unwrapUnaryRecords :: Bool
25− }
26−
27−-- | Default encoding @'SchemaOptions'@.
28−--
29−-- @
30−-- 'SchemaOptions'
31−-- { 'fieldLabelModifier' = id
32−-- , 'constructorTagModifier' = id
33−-- , 'datatypeNameModifier' = id
34−-- , 'allNullaryToStringTag' = True
35−-- , 'unwrapUnaryRecords' = False
36−-- }
37−-- @
38−defaultSchemaOptions :: SchemaOptions
39−defaultSchemaOptions = SchemaOptions
40− { fieldLabelModifier = id
41− , constructorTagModifier = id
42− , datatypeNameModifier = id
43− , allNullaryToStringTag = True
44− , unwrapUnaryRecords = False
45− }
46−
47−-- | Convert 'Aeson.Options' to 'SchemaOptions'.
48−--
49−-- Specifically the following fields get copied:
50−--
51−-- * 'fieldLabelModifier'
52−-- * 'constructorTagModifier'
53−-- * 'allNullaryToStringTag'
54−-- * 'unwrapUnaryRecords'
55−--
56−-- Note that these fields have no effect on `SchemaOptions`:
57−--
58−-- * 'Aeson.omitNothingFields'
59−-- * 'Aeson.sumEncoding'
60−-- * 'Aeson.tagSingleConstructors'
61−--
62−-- The rest is defined as in 'defaultSchemaOptions'.
63−--
64−-- @since 2.2.1
65−--
66−fromAesonOptions :: Aeson.Options -> SchemaOptions
67−fromAesonOptions opts = defaultSchemaOptions
68− { fieldLabelModifier = Aeson.fieldLabelModifier opts
69− , constructorTagModifier = Aeson.constructorTagModifier opts
70− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts
71− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts
72− }
stack.yaml+2−6
@@ -1,9 +1,5 @@
1−resolver: lts-14.3
1+flags: {}
22packages:
33- '.'
44extra-deps:
5−- optics-core-0.2
6−- optics-th-0.2
7−- optics-extra-0.2
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3
5+resolver: lts-3.12
swagger2.cabal+14−134
@@ -1,154 +1,34 @@
1−cabal-version: >=1.10
21name: swagger2
3−version: 2.5
4−
2+version: 0.1
53synopsis: Swagger 2.0 data model
6−category: Web, Swagger
7−description:
8− This library is intended to be used for decoding and encoding Swagger 2.0 API
9− specifications as well as manipulating them.
10− .
11− The original Swagger 2.0 specification is available at http://swagger.io/specification/.
12−
4+description: Please see README.md
135homepage: https://github.com/GetShopTV/swagger2
14−bug-reports: https://github.com/GetShopTV/swagger2/issues
156license: BSD3
167license-file: LICENSE
178author: Nickolay Kudasov
189maintainer: nickolay@getshoptv.com
19−copyright: (c) 2015-2016, GetShopTV
20−build-type: Custom
10+copyright: (c) 2015, GetShopTV
11+category: Web
12+build-type: Simple
2113extra-source-files:
2214 README.md
23− , CHANGELOG.md
24− , examples/*.hs
25− , include/overlapping-compat.h
26−tested-with:
27− GHC ==8.0.2
28− || ==8.2.2
29− || ==8.4.4
30− || ==8.6.5
31− || ==8.8.1
32−
33−custom-setup
34− setup-depends:
35− base, Cabal, cabal-doctest >=1.0.6 && <1.1
15+cabal-version: >=1.10
3616
3717library
3818 hs-source-dirs: src
39− include-dirs: include
4019 exposed-modules:
4120 Data.Swagger
42− Data.Swagger.Declare
43− Data.Swagger.Lens
44− Data.Swagger.Operation
45− Data.Swagger.Optics
46− Data.Swagger.ParamSchema
47− Data.Swagger.Schema
48− Data.Swagger.Schema.Generator
49− Data.Swagger.Schema.Validation
50− Data.Swagger.SchemaOptions
51−
52− -- internal modules
5321 Data.Swagger.Internal
54− Data.Swagger.Internal.Schema
55− Data.Swagger.Internal.Schema.Validation
56− Data.Swagger.Internal.ParamSchema
57− Data.Swagger.Internal.Utils
58− Data.Swagger.Internal.AesonUtils
59− Data.Swagger.Internal.TypeShape
60−
61− -- GHC boot libraries
62− build-depends:
63− base >=4.9 && <4.14
64− , aeson-pretty >=0.8.7 && <0.9
65− , bytestring >=0.10.4.0 && <0.11
66− , containers >=0.5.5.1 && <0.7
67− , template-haskell >=2.9.0.0 && <2.16
68− , time >=1.4.2 && <1.10
69− , transformers >=0.3.0.0 && <0.6
70−
71− build-depends:
72− mtl >=2.1 && <2.3
73− , text >=1.2.3.0 && <1.3
74−
75− -- other dependencies
76− build-depends:
77− base-compat-batteries >=0.10.4 && <0.12
78− , aeson >=1.4.2.0 && <1.5
79− -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
80− , cookie >=0.4.3 && <0.5
81− , generics-sop >=0.3.2.0 && <0.6
82− , hashable >=1.2.7.0 && <1.4
83− , http-media >=0.7.1.2 && <0.9
84− , insert-ordered-containers >=0.2.3 && <0.3
85− , lens >=4.16.1 && <4.19
86− , network >=2.6.3.5 && <3.2
87− , optics-core >=0.2 && <0.3
88− , optics-th >=0.2 && <0.3
89− , scientific >=0.3.6.2 && <0.4
90− , transformers-compat >=0.3 && <0.7
91− , unordered-containers >=0.2.9.0 && <0.3
92− , uuid-types >=1.0.3 && <1.1
93− , vector >=0.12.0.1 && <0.13
94− , QuickCheck >=2.10.1 && <2.14
95−
22+ build-depends: base >= 4.7 && < 5
23+ , aeson
24+ , hashable
25+ , http-media
26+ , network
27+ , text
28+ , unordered-containers
29+ , url
9630 default-language: Haskell2010
9731
98−test-suite spec
99− type: exitcode-stdio-1.0
100− hs-source-dirs: test
101− main-is: Spec.hs
102−
103− -- From library parat
104− -- We need aeson's toEncoding for doctests too
105− build-depends:
106− base
107− , swagger2
108− , aeson
109− , base-compat-batteries
110− , bytestring
111− , containers
112− , hashable
113− , insert-ordered-containers
114− , lens
115− , mtl
116− , template-haskell
117− , text
118− , time
119− , unordered-containers
120− , vector
121− , QuickCheck
122−
123− -- test-suite only dependencies
124− build-depends:
125− hspec >=2.5.5 && <2.8
126− , HUnit >=1.6.0.0 && <1.7
127− , quickcheck-instances >=0.3.19 && <0.14
128− , utf8-string >=1.0.1.1 && <1.1
129−
130− -- https://github.com/haskell/cabal/issues/3708
131− build-tool-depends:
132− hspec-discover:hspec-discover >=2.5.5 && <2.8
133−
134− other-modules:
135− SpecCommon
136− Data.SwaggerSpec
137− Data.Swagger.CommonTestTypes
138− Data.Swagger.ParamSchemaSpec
139− Data.Swagger.SchemaSpec
140− Data.Swagger.Schema.ValidationSpec
141− Data.Swagger.Schema.GeneratorSpec
142− default-language: Haskell2010
143−
144−test-suite doctests
145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
146− build-depends: base, doctest, Glob, QuickCheck
147− default-language: Haskell2010
148− hs-source-dirs: test
149− main-is: doctests.hs
150− type: exitcode-stdio-1.0
151−
15232source-repository head
15333 type: git
15434 location: https://github.com/GetShopTV/swagger2.git
test/Data/Swagger/CommonTestTypes.hsdeleted−679
@@ -1,679 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE QuasiQuotes #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.CommonTestTypes where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)
11−import Data.Aeson.QQ.Simple
12−import Data.Aeson.Types (toJSONKeyText)
13−import Data.Char
14−import Data.Map (Map)
15−import Data.Proxy
16−import Data.Set (Set)
17−import qualified Data.Text as Text
18−import GHC.Generics
19−
20−import Data.Swagger
21−
22−-- ========================================================================
23−-- Unit type
24−-- ========================================================================
25−
26−data Unit = Unit deriving (Generic)
27−instance ToParamSchema Unit
28−instance ToSchema Unit
29−
30−unitSchemaJSON :: Value
31−unitSchemaJSON = [aesonQQ|
32−{
33− "type": "string",
34− "enum": ["Unit"]
35−}
36−|]
37−
38−-- ========================================================================
39−-- Color (enum)
40−-- ========================================================================
41−data Color
42− = Red
43− | Green
44− | Blue
45− deriving (Generic)
46−instance ToParamSchema Color
47−instance ToSchema Color
48−
49−colorSchemaJSON :: Value
50−colorSchemaJSON = [aesonQQ|
51−{
52− "type": "string",
53− "enum": ["Red", "Green", "Blue"]
54−}
55−|]
56−
57−-- ========================================================================
58−-- Shade (paramSchemaToNamedSchema)
59−-- ========================================================================
60−
61−data Shade = Dim | Bright deriving (Generic)
62−instance ToParamSchema Shade
63−
64−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
65−
66−shadeSchemaJSON :: Value
67−shadeSchemaJSON = [aesonQQ|
68−{
69− "type": "string",
70− "enum": ["Dim", "Bright"]
71−}
72−|]
73−
74−-- ========================================================================
75−-- Paint (record with bounded enum property)
76−-- ========================================================================
77−
78−newtype Paint = Paint { color :: Color }
79− deriving (Generic)
80−instance ToSchema Paint
81−
82−paintSchemaJSON :: Value
83−paintSchemaJSON = [aesonQQ|
84−{
85− "type": "object",
86− "properties":
87− {
88− "color":
89− {
90− "$ref": "#/definitions/Color"
91− }
92− },
93− "required": ["color"]
94−}
95−|]
96−
97−paintInlinedSchemaJSON :: Value
98−paintInlinedSchemaJSON = [aesonQQ|
99−{
100− "type": "object",
101− "properties":
102− {
103− "color":
104− {
105− "type": "string",
106− "enum": ["Red", "Green", "Blue"]
107− }
108− },
109− "required": ["color"]
110−}
111−|]
112−
113−-- ========================================================================
114−-- Status (constructorTagModifier)
115−-- ========================================================================
116−
117−data Status
118− = StatusOk
119− | StatusError
120− deriving (Generic)
121−
122−instance ToParamSchema Status where
123− toParamSchema = genericToParamSchema defaultSchemaOptions
124− { constructorTagModifier = map toLower . drop (length "Status") }
125−instance ToSchema Status where
126− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
127− { constructorTagModifier = map toLower . drop (length "Status") }
128−
129−statusSchemaJSON :: Value
130−statusSchemaJSON = [aesonQQ|
131−{
132− "type": "string",
133− "enum": ["ok", "error"]
134−}
135−|]
136−
137−-- ========================================================================
138−-- Email (newtype with unwrapUnaryRecords set to True)
139−-- ========================================================================
140−
141−newtype Email = Email { getEmail :: String }
142− deriving (Generic)
143−instance ToParamSchema Email
144−instance ToSchema Email where
145− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
146− { unwrapUnaryRecords = True }
147−
148−emailSchemaJSON :: Value
149−emailSchemaJSON = [aesonQQ|
150−{
151− "type": "string"
152−}
153−|]
154−
155−-- ========================================================================
156−-- UserId (non-record newtype)
157−-- ========================================================================
158−
159−newtype UserId = UserId Integer
160− deriving (Eq, Ord, Generic)
161−instance ToParamSchema UserId
162−instance ToSchema UserId
163−
164−userIdSchemaJSON :: Value
165−userIdSchemaJSON = [aesonQQ|
166−{
167− "type": "integer"
168−}
169−|]
170−
171−-- ========================================================================
172−-- UserGroup (set newtype)
173−-- ========================================================================
174−
175−newtype UserGroup = UserGroup (Set UserId)
176− deriving (Generic)
177−instance ToSchema UserGroup
178−
179−userGroupSchemaJSON :: Value
180−userGroupSchemaJSON = [aesonQQ|
181−{
182− "type": "array",
183− "items": { "$ref": "#/definitions/UserId" },
184− "uniqueItems": true
185−}
186−|]
187−
188−-- ========================================================================
189−-- Person (simple record with optional fields)
190−-- ========================================================================
191−data Person = Person
192− { name :: String
193− , phone :: Integer
194− , email :: Maybe String
195− } deriving (Generic)
196−
197−instance ToSchema Person
198−
199−personSchemaJSON :: Value
200−personSchemaJSON = [aesonQQ|
201−{
202− "type": "object",
203− "properties":
204− {
205− "name": { "type": "string" },
206− "phone": { "type": "integer" },
207− "email": { "type": "string" }
208− },
209− "required": ["name", "phone"]
210−}
211−|]
212−
213−-- ========================================================================
214−-- Player (record newtype)
215−-- ========================================================================
216−
217−newtype Player = Player
218− { position :: Point
219− } deriving (Generic)
220−instance ToSchema Player
221−
222−playerSchemaJSON :: Value
223−playerSchemaJSON = [aesonQQ|
224−{
225− "type": "object",
226− "properties":
227− {
228− "position":
229− {
230− "$ref": "#/definitions/Point"
231− }
232− },
233− "required": ["position"]
234−}
235−|]
236−
237−newtype Players = Players [Inlined Player]
238− deriving (Generic)
239−instance ToSchema Players
240−
241−playersSchemaJSON :: Value
242−playersSchemaJSON = [aesonQQ|
243−{
244− "type": "array",
245− "items":
246− {
247− "type": "object",
248− "properties":
249− {
250− "position":
251− {
252− "$ref": "#/definitions/Point"
253− }
254− },
255− "required": ["position"]
256− }
257−}
258−|]
259−
260−-- ========================================================================
261−-- Character (sum type with ref and record in alternative)
262−-- ========================================================================
263−
264−data Character
265− = PC Player
266− | NPC { npcName :: String, npcPosition :: Point }
267− deriving (Generic)
268−instance ToSchema Character
269−
270−characterSchemaJSON :: Value
271−characterSchemaJSON = [aesonQQ|
272−{
273− "type": "object",
274− "properties":
275− {
276− "PC": { "$ref": "#/definitions/Player" },
277− "NPC":
278− {
279− "type": "object",
280− "properties":
281− {
282− "npcName": { "type": "string" },
283− "npcPosition": { "$ref": "#/definitions/Point" }
284− },
285− "required": ["npcName", "npcPosition"]
286− }
287− },
288− "maxProperties": 1,
289− "minProperties": 1
290−}
291−|]
292−
293−characterInlinedSchemaJSON :: Value
294−characterInlinedSchemaJSON = [aesonQQ|
295−{
296− "type": "object",
297− "properties":
298− {
299− "PC":
300− {
301− "type": "object",
302− "properties":
303− {
304− "position":
305− {
306− "type": "object",
307− "properties":
308− {
309− "x": { "type": "number", "format": "double" },
310− "y": { "type": "number", "format": "double" }
311− },
312− "required": ["x", "y"]
313− }
314− },
315− "required": ["position"]
316− },
317− "NPC":
318− {
319− "type": "object",
320− "properties":
321− {
322− "npcName": { "type": "string" },
323− "npcPosition":
324− {
325− "type": "object",
326− "properties":
327− {
328− "x": { "type": "number", "format": "double" },
329− "y": { "type": "number", "format": "double" }
330− },
331− "required": ["x", "y"]
332− }
333− },
334− "required": ["npcName", "npcPosition"]
335− }
336− },
337− "maxProperties": 1,
338− "minProperties": 1
339−}
340−|]
341−
342−characterInlinedPlayerSchemaJSON :: Value
343−characterInlinedPlayerSchemaJSON = [aesonQQ|
344−{
345− "type": "object",
346− "properties":
347− {
348− "PC":
349− {
350− "type": "object",
351− "properties":
352− {
353− "position":
354− {
355− "$ref": "#/definitions/Point"
356− }
357− },
358− "required": ["position"]
359− },
360− "NPC":
361− {
362− "type": "object",
363− "properties":
364− {
365− "npcName": { "type": "string" },
366− "npcPosition": { "$ref": "#/definitions/Point" }
367− },
368− "required": ["npcName", "npcPosition"]
369− }
370− },
371− "maxProperties": 1,
372− "minProperties": 1
373−}
374−|]
375−
376−-- ========================================================================
377−-- ISPair (non-record product data type)
378−-- ========================================================================
379−data ISPair = ISPair Integer String
380− deriving (Generic)
381−
382−instance ToSchema ISPair
383−
384−ispairSchemaJSON :: Value
385−ispairSchemaJSON = [aesonQQ|
386−{
387− "type": "array",
388− "items":
389− [
390− { "type": "integer" },
391− { "type": "string" }
392− ],
393− "minItems": 2,
394− "maxItems": 2
395−}
396−|]
397−
398−-- ========================================================================
399−-- Point (record data type with custom fieldLabelModifier)
400−-- ========================================================================
401−
402−data Point = Point
403− { pointX :: Double
404− , pointY :: Double
405− } deriving (Generic)
406−
407−instance ToSchema Point where
408− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
409− { fieldLabelModifier = map toLower . drop (length "point") }
410−
411−pointSchemaJSON :: Value
412−pointSchemaJSON = [aesonQQ|
413−{
414− "type": "object",
415− "properties":
416− {
417− "x": { "type": "number", "format": "double" },
418− "y": { "type": "number", "format": "double" }
419− },
420− "required": ["x", "y"]
421−}
422−|]
423−
424−-- ========================================================================
425−-- Point (record data type with multiple fields)
426−-- ========================================================================
427−
428−data Point5 = Point5
429− { point5X :: Double
430− , point5Y :: Double
431− , point5Z :: Double
432− , point5U :: Double
433− , point5V :: Double -- 5 dimensional!
434− } deriving (Generic)
435−
436−instance ToSchema Point5 where
437− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
438− { fieldLabelModifier = map toLower . drop (length "point5") }
439−
440−point5SchemaJSON :: Value
441−point5SchemaJSON = [aesonQQ|
442−{
443− "type": "object",
444− "properties":
445− {
446− "x": { "type": "number", "format": "double" },
447− "y": { "type": "number", "format": "double" },
448− "z": { "type": "number", "format": "double" },
449− "u": { "type": "number", "format": "double" },
450− "v": { "type": "number", "format": "double" }
451− },
452− "required": ["x", "y", "z", "u", "v"]
453−}
454−|]
455−
456−point5Properties :: [String]
457−point5Properties = ["x", "y", "z", "u", "v"]
458−
459−-- ========================================================================
460−-- MyRoseTree (custom datatypeNameModifier)
461−-- ========================================================================
462−
463−data MyRoseTree = MyRoseTree
464− { root :: String
465− , trees :: [MyRoseTree]
466− } deriving (Generic)
467−
468−instance ToSchema MyRoseTree where
469− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
470− { datatypeNameModifier = drop (length "My") }
471−
472−myRoseTreeSchemaJSON :: Value
473−myRoseTreeSchemaJSON = [aesonQQ|
474−{
475− "type": "object",
476− "properties":
477− {
478− "root": { "type": "string" },
479− "trees":
480− {
481− "type": "array",
482− "items":
483− {
484− "$ref": "#/definitions/RoseTree"
485− }
486− }
487− },
488− "required": ["root", "trees"]
489−}
490−|]
491−
492−data MyRoseTree' = MyRoseTree'
493− { root' :: String
494− , trees' :: [MyRoseTree']
495− } deriving (Generic)
496−
497−instance ToSchema MyRoseTree' where
498− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
499− { datatypeNameModifier = map toLower }
500−
501−myRoseTreeSchemaJSON' :: Value
502−myRoseTreeSchemaJSON' = [aesonQQ|
503−{
504− "type": "object",
505− "properties":
506− {
507− "root'": { "type": "string" },
508− "trees'":
509− {
510− "type": "array",
511− "items":
512− {
513− "$ref": "#/definitions/myrosetree'"
514− }
515− }
516− },
517− "required": ["root'", "trees'"]
518−}
519−|]
520−
521−-- ========================================================================
522−-- Inlined (newtype for inlining schemas)
523−-- ========================================================================
524−
525−newtype Inlined a = Inlined { getInlined :: a }
526−
527−instance ToSchema a => ToSchema (Inlined a) where
528− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
529− where
530− unname (NamedSchema _ s) = NamedSchema Nothing s
531−
532−-- ========================================================================
533−-- Light (sum type with unwrapUnaryRecords)
534−-- ========================================================================
535−
536−data Light
537− = NoLight
538− | LightFreq Double
539− | LightColor Color
540− | LightWaveLength { waveLength :: Double }
541− deriving (Generic)
542−
543−instance ToSchema Light where
544− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
545− { unwrapUnaryRecords = True }
546−
547−lightSchemaJSON :: Value
548−lightSchemaJSON = [aesonQQ|
549−{
550− "type": "object",
551− "properties":
552− {
553− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
554− "LightFreq": { "type": "number", "format": "double" },
555− "LightColor": { "$ref": "#/definitions/Color" },
556− "LightWaveLength": { "type": "number", "format": "double" }
557− },
558− "maxProperties": 1,
559− "minProperties": 1
560−}
561−|]
562−
563−lightInlinedSchemaJSON :: Value
564−lightInlinedSchemaJSON = [aesonQQ|
565−{
566− "type": "object",
567− "properties":
568− {
569− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
570− "LightFreq": { "type": "number", "format": "double" },
571− "LightColor":
572− {
573− "type": "string",
574− "enum": ["Red", "Green", "Blue"]
575− },
576− "LightWaveLength": { "type": "number", "format": "double" }
577− },
578− "maxProperties": 1,
579− "minProperties": 1
580−}
581−|]
582−
583−-- ========================================================================
584−-- ResourceId (series of newtypes)
585−-- ========================================================================
586−
587−newtype Id = Id String deriving (Generic)
588−instance ToSchema Id
589−
590−newtype ResourceId = ResourceId Id deriving (Generic)
591−instance ToSchema ResourceId
592−
593−-- ========================================================================
594−-- ButtonImages (bounded enum key mapping)
595−-- ========================================================================
596−
597−data ButtonState = Neutral | Focus | Active | Hover | Disabled
598− deriving (Show, Bounded, Enum, Generic)
599−
600−instance ToJSON ButtonState
601−instance ToSchema ButtonState
602−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
603−
604−type ImageUrl = Text.Text
605−
606−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
607− deriving (Generic)
608−
609−instance ToJSON ButtonImages where
610− toJSON = toJSON . getButtonImages
611−
612−instance ToSchema ButtonImages where
613− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
614− declareSchemaBoundedEnumKeyMapping
615−
616−buttonImagesSchemaJSON :: Value
617−buttonImagesSchemaJSON = [aesonQQ|
618−{
619− "type": "object",
620− "properties":
621− {
622− "Neutral": { "type": "string" },
623− "Focus": { "type": "string" },
624− "Active": { "type": "string" },
625− "Hover": { "type": "string" },
626− "Disabled": { "type": "string" }
627− }
628−}
629−|]
630−
631−-- ========================================================================
632−-- SingleMaybeField (single field data with optional field)
633−-- ========================================================================
634−
635−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
636− deriving (Show, Generic)
637−
638−instance ToJSON SingleMaybeField
639−instance ToSchema SingleMaybeField
640−
641−singleMaybeFieldSchemaJSON :: Value
642−singleMaybeFieldSchemaJSON = [aesonQQ|
643−{
644− "type": "object",
645− "properties":
646− {
647− "singleMaybeField": { "type": "string" }
648− }
649−}
650−|]
651−
652−
653−-- ========================================================================
654−-- TimeOfDay
655−-- ========================================================================
656−data TimeOfDay
657− = Int
658− | Pico
659− deriving (Generic)
660−instance ToSchema TimeOfDay
661−instance ToParamSchema TimeOfDay
662−
663−
664−timeOfDaySchemaJSON :: Value
665−timeOfDaySchemaJSON = [aesonQQ|
666−{
667− "example": "12:33:15",
668− "type": "string",
669− "format": "hh:MM:ss"
670−}
671−|]
672−
673−timeOfDayParamSchemaJSON :: Value
674−timeOfDayParamSchemaJSON = [aesonQQ|
675−{
676− "type": "string",
677− "format": "hh:MM:ss"
678−}
679−|]
test/Data/Swagger/ParamSchemaSpec.hsdeleted−40
@@ -1,40 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−module Data.Swagger.ParamSchemaSpec where
8−
9−import Data.Aeson
10−import Data.Aeson.QQ.Simple
11−import Data.Char
12−import Data.Proxy
13−import GHC.Generics
14−
15−import Data.Swagger
16−import Data.Swagger.Internal (SwaggerKind(..))
17−
18−import Data.Swagger.CommonTestTypes
19−import SpecCommon
20−import Test.Hspec
21−import Data.Time.LocalTime
22−
23−import qualified Data.HashMap.Strict as HM
24−
25−checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
27−
28−spec :: Spec
29−spec = do
30− describe "Generic ToParamSchema" $ do
31− context "Unit" $ checkToParamSchema (Proxy :: Proxy Unit) unitSchemaJSON
32− context "Color (bounded enum)" $ checkToParamSchema (Proxy :: Proxy Color) colorSchemaJSON
33− context "Status (constructorTagModifier)" $ checkToParamSchema (Proxy :: Proxy Status) statusSchemaJSON
34− context "Unary records" $ do
35− context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
36− context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
38−
39−main :: IO ()
40−main = hspec spec
test/Data/Swagger/Schema/GeneratorSpec.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE PackageImports #-}
4−module Data.Swagger.Schema.GeneratorSpec where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Data.Swagger
10−import Data.Swagger.Schema.Generator
11−
12−import Control.Lens.Operators
13−import Data.Aeson
14−import Data.Hashable (Hashable)
15−import Data.HashMap.Strict (HashMap)
16−import qualified Data.HashMap.Strict as HashMap
17−import "unordered-containers" Data.HashSet (HashSet)
18−import qualified "unordered-containers" Data.HashSet as HashSet
19−import Data.Int
20−import Data.IntMap (IntMap)
21−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
22−import Data.Map (Map, fromList)
23−import Data.Monoid (mempty)
24−import Data.Proxy
25−import Data.Proxy
26−import Data.Set (Set)
27−import qualified Data.Text as T
28−import qualified Data.Text.Lazy as TL
29−import Data.Time
30−import Data.Version (Version)
31−import Data.Word
32−import GHC.Generics
33−
34−import Test.Hspec
35−import Test.Hspec.QuickCheck
36−import Test.QuickCheck
37−
38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
39−shouldValidate = validateFromJSON
40−
41−
42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
43−shouldNotValidate = expectFailure . shouldValidate
44−
45−
46−spec :: Spec
47−spec = do
48− describe "FromJSON validation" $ do
49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
64− prop "String" $ shouldValidate (Proxy :: Proxy String)
65− prop "()" $ shouldValidate (Proxy :: Proxy ())
66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
74− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
82− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
83− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
84− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
85− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
86− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
87− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
88− describe "Invalid FromJSON validation" $ do
89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
93−
94−-- =============================
95−-- Data types and bunk instances
96−-- =============================
97−
98−data WrongType = WrongType Bool
99−
100−instance FromJSON WrongType where
101− parseJSON = withBool "WrongType" $ return . WrongType
102−
103−instance ToSchema WrongType where
104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105− mempty
106− & type_ ?~ SwaggerObject
107−
108−
109−data MissingRequired = MissingRequired
110− { propA :: String
111− , propB :: Bool
112− }
113−
114−instance FromJSON MissingRequired where
115− parseJSON = withObject "MissingRequired" $ \o ->
116− MissingRequired
117− <$> o .: "propA"
118− <*> o .: "propB"
119−
120−instance ToSchema MissingRequired where
121− declareNamedSchema _ = do
122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124− return . NamedSchema (Just "MissingRequired") $
125− mempty
126− & type_ ?~ SwaggerObject
127− & properties .~ [("propA", stringSchema)
128− ,("propB", boolSchema)
129− ]
130− & required .~ ["propA"]
131−
132−data MissingProperty = MissingProperty
133− { propC :: String
134− , propD :: Bool
135− }
136−
137−instance FromJSON MissingProperty where
138− parseJSON = withObject "MissingProperty" $ \o ->
139− MissingProperty
140− <$> o .: "propC"
141− <*> o .: "propD"
142−
143−instance ToSchema MissingProperty where
144− declareNamedSchema _ = do
145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146− return . NamedSchema (Just "MissingProperty") $
147− mempty
148− & type_ ?~ SwaggerObject
149− & properties .~ [("propC", stringSchema)]
150− & required .~ ["propC"]
151−
152−data WrongPropType = WrongPropType
153− { propE :: String
154− }
155−
156−instance FromJSON WrongPropType where
157− parseJSON = withObject "WrongPropType" $ \o ->
158− WrongPropType
159− <$> o .: "propE"
160−
161−instance ToSchema WrongPropType where
162− declareNamedSchema _ = do
163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164− return . NamedSchema (Just "WrongPropType") $
165− mempty
166− & type_ ?~ SwaggerObject
167− & properties .~ [("propE", boolSchema)]
168− & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hsdeleted−278
@@ -1,278 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# OPTIONS_GHC -fno-warn-orphans #-}
7−module Data.Swagger.Schema.ValidationSpec where
8−
9−import Control.Applicative
10−import Control.Lens ((&), (.~), (?~))
11−import Data.Aeson
12−import Data.Aeson.Types
13−import Data.Hashable (Hashable)
14−import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashMap.Strict as HashMap
16−import "unordered-containers" Data.HashSet (HashSet)
17−import qualified "unordered-containers" Data.HashSet as HashSet
18−import Data.Int
19−import Data.IntMap (IntMap)
20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
21−import Data.Map (Map, fromList)
22−import Data.Monoid (mempty)
23−import Data.Proxy
24−import Data.Set (Set)
25−import qualified Data.Text as T
26−import qualified Data.Text.Lazy as TL
27−import Data.Time
28−import Data.Version (Version)
29−import Data.Word
30−import GHC.Generics
31−
32−import Data.Swagger
33−import Data.Swagger.Declare
34−
35−import Test.Hspec
36−import Test.Hspec.QuickCheck
37−import Test.QuickCheck
38−import Test.QuickCheck.Instances ()
39−
40−shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
41−shouldValidate _ x = validateToJSON x == []
42−
43−shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
44−shouldNotValidate f = not . null . validateJSON defs sch . f
45− where
46− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
47−
48−spec :: Spec
49−spec = do
50− describe "Validation" $ do
51− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
52− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
53− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
54− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
55− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
56− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
57− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
58− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
59− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
60− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
61− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
62− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
63− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
64− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
65− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
66− prop "String" $ shouldValidate (Proxy :: Proxy String)
67− prop "()" $ shouldValidate (Proxy :: Proxy ())
68− prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
69− prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
70− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
71− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
72− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
73− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
74− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
75− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
77− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
78− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
79− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
80− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
81− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
82− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
83− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
84− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
85− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
87− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
88− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
89− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
90− prop "Person" $ shouldValidate (Proxy :: Proxy Person)
91− prop "Color" $ shouldValidate (Proxy :: Proxy Color)
92− prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
93− prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
94− prop "Light" $ shouldValidate (Proxy :: Proxy Light)
95− prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
96− prop "Version" $ shouldValidate (Proxy :: Proxy Version)
97− prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
98−
99− describe "invalid cases" $ do
100− prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON
101− prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON
102− prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON
103− prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON
104− prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON
105−
106−main :: IO ()
107−main = hspec spec
108−
109−-- ========================================================================
110−-- Person (simple record with optional fields)
111−-- ========================================================================
112−data Person = Person
113− { name :: String
114− , phone :: Integer
115− , email :: Maybe String
116− } deriving (Show, Generic)
117−
118−instance ToJSON Person
119−instance ToSchema Person
120−
121−instance Arbitrary Person where
122− arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
123−
124−invalidPersonToJSON :: Person -> Value
125−invalidPersonToJSON Person{..} = object
126− [ T.pack "personName" .= toJSON name
127− , T.pack "personPhone" .= toJSON phone
128− , T.pack "personEmail" .= toJSON email
129− ]
130−
131−-- ========================================================================
132−-- Color (enum)
133−-- ========================================================================
134−data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)
135−
136−instance ToJSON Color
137−instance ToSchema Color
138−
139−instance Arbitrary Color where
140− arbitrary = arbitraryBoundedEnum
141−
142−invalidColorToJSON :: Color -> Value
143−invalidColorToJSON Red = toJSON "red"
144−invalidColorToJSON Green = toJSON "green"
145−invalidColorToJSON Blue = toJSON "blue"
146−
147−-- ========================================================================
148−-- Paint (record with bounded enum property)
149−-- ========================================================================
150−
151−newtype Paint = Paint { color :: Color }
152− deriving (Show, Generic)
153−
154−instance ToJSON Paint
155−instance ToSchema Paint
156−
157−instance Arbitrary Paint where
158− arbitrary = Paint <$> arbitrary
159−
160−invalidPaintToJSON :: Paint -> Value
161−invalidPaintToJSON = toJSON . color
162−
163−-- ========================================================================
164−-- MyRoseTree (custom datatypeNameModifier)
165−-- ========================================================================
166−
167−data MyRoseTree = MyRoseTree
168− { root :: String
169− , trees :: [MyRoseTree]
170− } deriving (Show, Generic)
171−
172−instance ToJSON MyRoseTree
173−
174−instance ToSchema MyRoseTree where
175− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
176− { datatypeNameModifier = drop (length "My") }
177−
178−instance Arbitrary MyRoseTree where
179− arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary)
180− where
181− limit = 4
182− cut 0 (MyRoseTree x _ ) = MyRoseTree x []
183− cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs)
184−
185−-- ========================================================================
186−-- Light (sum type)
187−-- ========================================================================
188−
189−data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
190−
191−instance ToSchema Light where
192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
193−
194−instance ToJSON Light where
195− toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
196−
197−instance Arbitrary Light where
198− arbitrary = oneof
199− [ return NoLight
200− , LightFreq <$> arbitrary
201− , LightColor <$> arbitrary
202− ]
203−
204−invalidLightToJSON :: Light -> Value
205−invalidLightToJSON = genericToJSON defaultOptions
206−
207−-- ========================================================================
208−-- ButtonImages (bounded enum key mapping)
209−-- ========================================================================
210−
211−data ButtonState = Neutral | Focus | Active | Hover | Disabled
212− deriving (Show, Eq, Ord, Bounded, Enum, Generic)
213−
214−instance ToJSON ButtonState
215−instance ToSchema ButtonState
216−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
217−
218−instance Arbitrary ButtonState where
219− arbitrary = arbitraryBoundedEnum
220−
221−type ImageUrl = T.Text
222−
223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
224− deriving (Show, Generic)
225−
226−instance ToJSON ButtonImages where
227− toJSON = toJSON . getButtonImages
228−
229−instance ToSchema ButtonImages where
230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
231− declareSchemaBoundedEnumKeyMapping
232−
233−invalidButtonImagesToJSON :: ButtonImages -> Value
234−invalidButtonImagesToJSON = genericToJSON defaultOptions
235−
236−instance Arbitrary ButtonImages where
237− arbitrary = ButtonImages <$> arbitrary
238−
239−-- ========================================================================
240−-- FreeForm (wraps a raw JSON Value)
241−-- ========================================================================
242−
243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
244− deriving (Show, Generic)
245−
246−instance ToJSON FreeForm where
247− toJSON = toJSON . jsonContent
248−
249−instance ToSchema FreeForm where
250− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
251− & type_ ?~ SwaggerObject
252− & additionalProperties ?~ AdditionalPropertiesAllowed True
253−
254−instance Arbitrary FreeForm where
255− arbitrary = (FreeForm . fromList) <$> genObj
256− where
257− genObj = listOf $ do
258− k <- arbitrary
259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
260− pure (k, v)
261−
262−instance Eq ZonedTime where
263− ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
264−
265−-- ========================================================================
266−-- Arbitrary instance for Data.Aeson.Value
267−-- ========================================================================
268−
269−instance Arbitrary Value where
270− -- Weights are almost random
271− -- Uniform oneof tends not to build complex objects cause of recursive call.
272− arbitrary = resize 4 $ frequency
273− [ (3, Object <$> arbitrary)
274− , (3, Array <$> arbitrary)
275− , (3, String <$> arbitrary)
276− , (3, Number <$> arbitrary)
277− , (3, Bool <$> arbitrary)
278− , (1, return Null) ]
test/Data/Swagger/SchemaSpec.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE QuasiQuotes #-}
5−module Data.Swagger.SchemaSpec where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens ((^.))
11−import Data.Aeson (Value)
12−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
13−import Data.Proxy
14−import Data.Set (Set)
15−import qualified Data.Text as Text
16−
17−import Data.Swagger
18−import Data.Swagger.Declare
19−
20−import Data.Swagger.CommonTestTypes
21−import SpecCommon
22−import Test.Hspec
23−
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
27−checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
28−checkToSchema proxy js = toSchema proxy <=> js
29−
30−checkSchemaName :: ToSchema a => Maybe String -> Proxy a -> Spec
31−checkSchemaName sname proxy =
32− it ("schema name is " ++ show sname) $
33− schemaName proxy `shouldBe` fmap Text.pack sname
34−
35−checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
36−checkDefs proxy names =
37− it ("uses these definitions " ++ show names) $
38− InsOrdHashMap.keys defs `shouldBe` map Text.pack names
39− where
40− defs = execDeclare (declareNamedSchema proxy) mempty
41−
42−checkProperties :: ToSchema a => Proxy a -> [String] -> Spec
43−checkProperties proxy names =
44− it ("has these fields in order " ++ show names) $
45− InsOrdHashMap.keys fields `shouldBe` map Text.pack names
46− where
47− fields = toSchema proxy ^. properties
48−
49−checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
50−checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
51−
52−checkInlinedSchemas :: ToSchema a => [String] -> Proxy a -> Value -> Spec
53−checkInlinedSchemas names proxy js = inlineSchemas (map Text.pack names) defs s <=> js
54− where
55− (defs, s) = runDeclare (declareSchema proxy) mempty
56−
57−checkInlinedRecSchema :: ToSchema a => Proxy a -> Value -> Spec
58−checkInlinedRecSchema proxy js = inlineNonRecursiveSchemas defs s <=> js
59− where
60− (defs, s) = runDeclare (declareSchema proxy) mempty
61−
62−spec :: Spec
63−spec = do
64− describe "Generic ToSchema" $ do
65− context "Unit" $ checkToSchema (Proxy :: Proxy Unit) unitSchemaJSON
66− context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
67− context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
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
72− context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
73− context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
74− context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
75− context "UserGroup (set newtype)" $ checkToSchema (Proxy :: Proxy UserGroup) userGroupSchemaJSON
76− context "Unary records" $ do
77− context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
78− context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
79− context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
81− context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
82− context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
84− context "Sum types" $ do
85− context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
86− context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
87− context "Light (sum with unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Light) lightSchemaJSON
88− context "Schema name" $ do
89− context "String" $ checkSchemaName Nothing (Proxy :: Proxy String)
90− context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float))
91− context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person)
92− context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade)
93− describe "Generic Definitions" $ do
94− context "Unit" $ checkDefs (Proxy :: Proxy Unit) []
95− context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]
96− context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
97− context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
98− context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
100− context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
101− context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
102− describe "Inlining Schemas" $ do
103− context "Paint" $ checkInlinedSchema (Proxy :: Proxy Paint) paintInlinedSchemaJSON
104− context "Character" $ checkInlinedSchema (Proxy :: Proxy Character) characterInlinedSchemaJSON
105− context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
106− context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
107− context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
108− context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
109− describe "Bounded Enum key mapping" $ do
110− context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
111− context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON
112−
113−main :: IO ()
114−main = hspec spec
test/Data/SwaggerSpec.hsdeleted−1702
@@ -1,1702 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−{-# LANGUAGE QuasiQuotes #-}
5−module Data.SwaggerSpec where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens
11−
12−import Data.Aeson
13−import Data.Aeson.QQ.Simple
14−import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
16−import Data.Text (Text)
17−
18−import Data.Swagger
19−import SpecCommon
20−import Test.Hspec hiding (example)
21−
22−spec :: Spec
23−spec = do
24− describe "host" $ do
25− it "can decode the host port" $ do
26− let h = Just $ Host "localhost" (Just (fromInteger 8000))
27− swagger :: Swagger
28− swagger = swaggerExample
29− & host .~ h
30− parsed :: Swagger = either error id $ eitherDecode' $ encode swagger
31− parsed ^. host `shouldBe` h
32− describe "License Object" $ licenseExample <=> licenseExampleJSON
33− describe "Contact Object" $ contactExample <=> contactExampleJSON
34− describe "Info Object" $ infoExample <=> infoExampleJSON
35− describe "Operation Object" $ operationExample <=> operationExampleJSON
36− describe "Schema Object" $ do
37− context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
38− context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
39− context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
41− context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
42− describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
43− describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
44− describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
45− describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
48− describe "Swagger Object" $ do
49− context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
50− context "PetStore Example" $
51− it "decodes successfully" $ do
52− fromJSON petstoreExampleJSON `shouldSatisfy` (\x -> case x of Success (_ :: Swagger) -> True; _ -> False)
53−
54−main :: IO ()
55−main = hspec spec
56−
57−-- =======================================================================
58−-- Info object
59−-- =======================================================================
60−
61−infoExample :: Info
62−infoExample = mempty
63− & title .~ "Swagger Sample App"
64− & description ?~ "This is a sample server Petstore server."
65− & termsOfService ?~ "http://swagger.io/terms/"
66− & contact ?~ contactExample
67− & license ?~ licenseExample
68− & version .~ "1.0.1"
69−
70−infoExampleJSON :: Value
71−infoExampleJSON = [aesonQQ|
72−{
73− "title": "Swagger Sample App",
74− "description": "This is a sample server Petstore server.",
75− "termsOfService": "http://swagger.io/terms/",
76− "contact": {
77− "name": "API Support",
78− "url": "http://www.swagger.io/support",
79− "email": "support@swagger.io"
80− },
81− "license": {
82− "name": "Apache 2.0",
83− "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
84− },
85− "version": "1.0.1"
86−}
87−|]
88−
89−-- =======================================================================
90−-- Contact object
91−-- =======================================================================
92−
93−contactExample :: Contact
94−contactExample = mempty
95− & name ?~ "API Support"
96− & url ?~ URL "http://www.swagger.io/support"
97− & email ?~ "support@swagger.io"
98−
99−contactExampleJSON :: Value
100−contactExampleJSON = [aesonQQ|
101−{
102− "name": "API Support",
103− "url": "http://www.swagger.io/support",
104− "email": "support@swagger.io"
105−}
106−|]
107−
108−-- =======================================================================
109−-- License object
110−-- =======================================================================
111−
112−licenseExample :: License
113−licenseExample = "Apache 2.0"
114− & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"
115−
116−licenseExampleJSON :: Value
117−licenseExampleJSON = [aesonQQ|
118−{
119− "name": "Apache 2.0",
120− "url": "http://www.apache.org/licenses/LICENSE-2.0.html"
121−}
122−|]
123−
124−
125−-- =======================================================================
126−-- Operation object
127−-- =======================================================================
128−
129−operationExample :: Operation
130−operationExample = mempty
131− & tags .~ InsOrdHS.fromList ["pet"]
132− & summary ?~ "Updates a pet in the store with form data"
133− & description ?~ ""
134− & operationId ?~ "updatePetWithForm"
135− & consumes ?~ MimeList ["application/x-www-form-urlencoded"]
136− & produces ?~ MimeList ["application/json", "application/xml"]
137− & parameters .~ map Inline
138− [ mempty
139− & name .~ "petId"
140− & description ?~ "ID of pet that needs to be updated"
141− & required ?~ True
142− & schema .~ ParamOther (stringSchema ParamPath)
143− , mempty
144− & name .~ "name"
145− & description ?~ "Updated name of the pet"
146− & required ?~ False
147− & schema .~ ParamOther (stringSchema ParamFormData)
148− , mempty
149− & name .~ "status"
150− & description ?~ "Updated status of the pet"
151− & required ?~ False
152− & schema .~ ParamOther (stringSchema ParamFormData)
153− ]
154−
155− & at 200 ?~ "Pet updated."
156− & at 405 ?~ "Invalid input"
157− & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]
158− where
159− stringSchema :: ParamLocation -> ParamOtherSchema
160− stringSchema loc = mempty
161− & in_ .~ loc
162− & type_ ?~ SwaggerString
163−
164−operationExampleJSON :: Value
165−operationExampleJSON = [aesonQQ|
166−{
167− "tags": [
168− "pet"
169− ],
170− "summary": "Updates a pet in the store with form data",
171− "description": "",
172− "operationId": "updatePetWithForm",
173− "consumes": [
174− "application/x-www-form-urlencoded"
175− ],
176− "produces": [
177− "application/json",
178− "application/xml"
179− ],
180− "parameters": [
181− {
182− "name": "petId",
183− "in": "path",
184− "description": "ID of pet that needs to be updated",
185− "required": true,
186− "type": "string"
187− },
188− {
189− "name": "name",
190− "in": "formData",
191− "description": "Updated name of the pet",
192− "required": false,
193− "type": "string"
194− },
195− {
196− "name": "status",
197− "in": "formData",
198− "description": "Updated status of the pet",
199− "required": false,
200− "type": "string"
201− }
202− ],
203− "responses": {
204− "200": {
205− "description": "Pet updated."
206− },
207− "405": {
208− "description": "Invalid input"
209− }
210− },
211− "security": [
212− {
213− "petstore_auth": [
214− "write:pets",
215− "read:pets"
216− ]
217− }
218− ]
219−}
220−|]
221−
222−-- =======================================================================
223−-- Schema object
224−-- =======================================================================
225−
226−schemaPrimitiveExample :: Schema
227−schemaPrimitiveExample = mempty
228− & type_ ?~ SwaggerString
229− & format ?~ "email"
230−
231−schemaPrimitiveExampleJSON :: Value
232−schemaPrimitiveExampleJSON = [aesonQQ|
233−{
234− "type": "string",
235− "format": "email"
236−}
237−|]
238−
239−schemaSimpleModelExample :: Schema
240−schemaSimpleModelExample = mempty
241− & type_ ?~ SwaggerObject
242− & required .~ [ "name" ]
243− & properties .~
244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
245− , ("address", Ref (Reference "Address"))
246− , ("age", Inline $ mempty
247− & minimum_ ?~ 0
248− & type_ ?~ SwaggerInteger
249− & format ?~ "int32" ) ]
250−
251−schemaSimpleModelExampleJSON :: Value
252−schemaSimpleModelExampleJSON = [aesonQQ|
253−{
254− "type": "object",
255− "required": [
256− "name"
257− ],
258− "properties": {
259− "name": {
260− "type": "string"
261− },
262− "address": {
263− "$ref": "#/definitions/Address"
264− },
265− "age": {
266− "type": "integer",
267− "format": "int32",
268− "minimum": 0
269− }
270− }
271−}
272−|]
273−
274−schemaModelDictExample :: Schema
275−schemaModelDictExample = mempty
276− & type_ ?~ SwaggerObject
277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
278−
279−schemaModelDictExampleJSON :: Value
280−schemaModelDictExampleJSON = [aesonQQ|
281−{
282− "type": "object",
283− "additionalProperties": {
284− "type": "string"
285− }
286−}
287−|]
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−
302−schemaWithExampleExample :: Schema
303−schemaWithExampleExample = mempty
304− & type_ ?~ SwaggerObject
305− & properties .~
306− [ ("id", Inline $ mempty
307− & type_ ?~ SwaggerInteger
308− & format ?~ "int64" )
309− , ("name", Inline $ mempty
310− & type_ ?~ SwaggerString) ]
311− & required .~ [ "name" ]
312− & example ?~ [aesonQQ|
313− {
314− "name": "Puma",
315− "id": 1
316− }
317− |]
318−
319−schemaWithExampleExampleJSON :: Value
320−schemaWithExampleExampleJSON = [aesonQQ|
321−{
322− "type": "object",
323− "properties": {
324− "id": {
325− "type": "integer",
326− "format": "int64"
327− },
328− "name": {
329− "type": "string"
330− }
331− },
332− "required": [
333− "name"
334− ],
335− "example": {
336− "name": "Puma",
337− "id": 1
338− }
339−}
340−|]
341−
342−-- =======================================================================
343−-- Definitions object
344−-- =======================================================================
345−
346−definitionsExample :: HashMap Text Schema
347−definitionsExample =
348− [ ("Category", mempty
349− & type_ ?~ SwaggerObject
350− & properties .~
351− [ ("id", Inline $ mempty
352− & type_ ?~ SwaggerInteger
353− & format ?~ "int64")
354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
355− , ("Tag", mempty
356− & type_ ?~ SwaggerObject
357− & properties .~
358− [ ("id", Inline $ mempty
359− & type_ ?~ SwaggerInteger
360− & format ?~ "int64")
361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
362−
363−definitionsExampleJSON :: Value
364−definitionsExampleJSON = [aesonQQ|
365−{
366− "Category": {
367− "type": "object",
368− "properties": {
369− "id": {
370− "type": "integer",
371− "format": "int64"
372− },
373− "name": {
374− "type": "string"
375− }
376− }
377− },
378− "Tag": {
379− "type": "object",
380− "properties": {
381− "id": {
382− "type": "integer",
383− "format": "int64"
384− },
385− "name": {
386− "type": "string"
387− }
388− }
389− }
390−}
391−|]
392−
393−-- =======================================================================
394−-- Parameters Definition object
395−-- =======================================================================
396−
397−paramsDefinitionExample :: HashMap Text Param
398−paramsDefinitionExample =
399− [ ("skipParam", mempty
400− & name .~ "skip"
401− & description ?~ "number of items to skip"
402− & required ?~ True
403− & schema .~ ParamOther (mempty
404− & in_ .~ ParamQuery
405− & type_ ?~ SwaggerInteger
406− & format ?~ "int32" ))
407− , ("limitParam", mempty
408− & name .~ "limit"
409− & description ?~ "max records to return"
410− & required ?~ True
411− & schema .~ ParamOther (mempty
412− & in_ .~ ParamQuery
413− & type_ ?~ SwaggerInteger
414− & format ?~ "int32" )) ]
415−
416−paramsDefinitionExampleJSON :: Value
417−paramsDefinitionExampleJSON = [aesonQQ|
418−{
419− "skipParam": {
420− "name": "skip",
421− "in": "query",
422− "description": "number of items to skip",
423− "required": true,
424− "type": "integer",
425− "format": "int32"
426− },
427− "limitParam": {
428− "name": "limit",
429− "in": "query",
430− "description": "max records to return",
431− "required": true,
432− "type": "integer",
433− "format": "int32"
434− }
435−}
436−|]
437−
438−-- =======================================================================
439−-- Responses Definition object
440−-- =======================================================================
441−
442−responsesDefinitionExample :: HashMap Text Response
443−responsesDefinitionExample =
444− [ ("NotFound", mempty & description .~ "Entity not found.")
445− , ("IllegalInput", mempty & description .~ "Illegal input for operation.") ]
446−
447−responsesDefinitionExampleJSON :: Value
448−responsesDefinitionExampleJSON = [aesonQQ|
449−{
450− "NotFound": {
451− "description": "Entity not found."
452− },
453− "IllegalInput": {
454− "description": "Illegal input for operation."
455− }
456−}
457−|]
458−
459−-- =======================================================================
460−-- Responses Definition object
461−-- =======================================================================
462−
463−securityDefinitionsExample :: SecurityDefinitions
464−securityDefinitionsExample = SecurityDefinitions
465− [ ("api_key", SecurityScheme
466− { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
467− , _securitySchemeDescription = Nothing })
468− , ("petstore_auth", SecurityScheme
469− { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params
470− { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"
471− , _oauth2Scopes =
472− [ ("write:pets", "modify pets in your account")
473− , ("read:pets", "read your pets") ] } )
474− , _securitySchemeDescription = Nothing }) ]
475−
476−securityDefinitionsExampleJSON :: Value
477−securityDefinitionsExampleJSON = [aesonQQ|
478−{
479− "api_key": {
480− "type": "apiKey",
481− "name": "api_key",
482− "in": "header"
483− },
484− "petstore_auth": {
485− "type": "oauth2",
486− "authorizationUrl": "http://swagger.io/api/oauth/dialog",
487− "flow": "implicit",
488− "scopes": {
489− "write:pets": "modify pets in your account",
490− "read:pets": "read your pets"
491− }
492− }
493−}
494−|]
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−
536−-- =======================================================================
537−-- Swagger object
538−-- =======================================================================
539−
540−swaggerExample :: Swagger
541−swaggerExample = mempty
542− & basePath ?~ "/"
543− & schemes ?~ [Http]
544− & info .~ (mempty
545− & version .~ "1.0"
546− & title .~ "Todo API"
547− & license ?~ "MIT"
548− & license._Just.url ?~ URL "http://mit.com"
549− & description ?~ "This is a an API that tests servant-swagger support for a Todo API")
550− & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)
551− & at 200 ?~ Inline (mempty
552− & description .~ "OK"
553− & schema ?~ Inline (mempty
554− & type_ ?~ SwaggerObject
555− & example ?~ [aesonQQ|
556− {
557− "created": 100,
558− "description": "get milk"
559− } |]
560− & description ?~ "This is some real Todo right here"
561− & properties .~
562− [ ("created", Inline $ mempty
563− & type_ ?~ SwaggerInteger
564− & format ?~ "int32")
565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
566− & produces ?~ MimeList [ "application/json" ]
567− & parameters .~
568− [ Inline $ mempty
569− & required ?~ True
570− & name .~ "id"
571− & description ?~ "TodoId param"
572− & schema .~ ParamOther (mempty
573− & in_ .~ ParamPath
574− & type_ ?~ SwaggerString ) ]
575− & tags .~ InsOrdHS.fromList [ "todo" ] ))
576−
577−swaggerExampleJSON :: Value
578−swaggerExampleJSON = [aesonQQ|
579−{
580− "swagger": "2.0",
581− "basePath": "/",
582− "schemes": [
583− "http"
584− ],
585− "info": {
586− "version": "1.0",
587− "title": "Todo API",
588− "license": {
589− "url": "http://mit.com",
590− "name": "MIT"
591− },
592− "description": "This is a an API that tests servant-swagger support for a Todo API"
593− },
594− "paths": {
595− "/todo/{id}": {
596− "get": {
597− "responses": {
598− "200": {
599− "schema": {
600− "example": {
601− "created": 100,
602− "description": "get milk"
603− },
604− "type": "object",
605− "description": "This is some real Todo right here",
606− "properties": {
607− "created": {
608− "format": "int32",
609− "type": "integer"
610− },
611− "description": {
612− "type": "string"
613− }
614− }
615− },
616− "description": "OK"
617− }
618− },
619− "produces": [
620− "application/json"
621− ],
622− "parameters": [
623− {
624− "required": true,
625− "in": "path",
626− "name": "id",
627− "type": "string",
628− "description": "TodoId param"
629− }
630− ],
631− "tags": [
632− "todo"
633− ]
634− }
635− }
636− }
637−}
638−|]
639−
640−petstoreExampleJSON :: Value
641−petstoreExampleJSON = [aesonQQ|
642−{
643− "swagger":"2.0",
644− "info":{
645− "description":"This is a sample server Petstore server. You can find out more about Swagger at [http://swagger.io](http://swagger.io) or on [irc.freenode.net, #swagger](http://swagger.io/irc/). For this sample, you can use the api key `special-key` to test the authorization filters.",
646− "version":"1.0.0",
647− "title":"Swagger Petstore",
648− "termsOfService":"http://swagger.io/terms/",
649− "contact":{
650− "email":"apiteam@swagger.io"
651− },
652− "license":{
653− "name":"Apache 2.0",
654− "url":"http://www.apache.org/licenses/LICENSE-2.0.html"
655− }
656− },
657− "host":"petstore.swagger.io",
658− "basePath":"/v2",
659− "tags":[
660− {
661− "name":"pet",
662− "description":"Everything about your Pets",
663− "externalDocs":{
664− "description":"Find out more",
665− "url":"http://swagger.io"
666− }
667− },
668− {
669− "name":"store",
670− "description":"Access to Petstore orders"
671− },
672− {
673− "name":"user",
674− "description":"Operations about user",
675− "externalDocs":{
676− "description":"Find out more about our store",
677− "url":"http://swagger.io"
678− }
679− }
680− ],
681− "schemes":[
682− "http"
683− ],
684− "paths":{
685− "/pet":{
686− "post":{
687− "tags":[
688− "pet"
689− ],
690− "summary":"Add a new pet to the store",
691− "description":"",
692− "operationId":"addPet",
693− "consumes":[
694− "application/json",
695− "application/xml"
696− ],
697− "produces":[
698− "application/xml",
699− "application/json"
700− ],
701− "parameters":[
702− {
703− "in":"body",
704− "name":"body",
705− "description":"Pet object that needs to be added to the store",
706− "required":true,
707− "schema":{
708− "$ref":"#/definitions/Pet"
709− }
710− }
711− ],
712− "responses":{
713− "405":{
714− "description":"Invalid input"
715− }
716− },
717− "security":[
718− {
719− "petstore_auth":[
720− "write:pets",
721− "read:pets"
722− ]
723− }
724− ]
725− },
726− "put":{
727− "tags":[
728− "pet"
729− ],
730− "summary":"Update an existing pet",
731− "description":"",
732− "operationId":"updatePet",
733− "consumes":[
734− "application/json",
735− "application/xml"
736− ],
737− "produces":[
738− "application/xml",
739− "application/json"
740− ],
741− "parameters":[
742− {
743− "in":"body",
744− "name":"body",
745− "description":"Pet object that needs to be added to the store",
746− "required":true,
747− "schema":{
748− "$ref":"#/definitions/Pet"
749− }
750− }
751− ],
752− "responses":{
753− "400":{
754− "description":"Invalid ID supplied"
755− },
756− "404":{
757− "description":"Pet not found"
758− },
759− "405":{
760− "description":"Validation exception"
761− }
762− },
763− "security":[
764− {
765− "petstore_auth":[
766− "write:pets",
767− "read:pets"
768− ]
769− }
770− ]
771− }
772− },
773− "/pet/findByStatus":{
774− "get":{
775− "tags":[
776− "pet"
777− ],
778− "summary":"Finds Pets by status",
779− "description":"Multiple status values can be provided with comma seperated strings",
780− "operationId":"findPetsByStatus",
781− "produces":[
782− "application/xml",
783− "application/json"
784− ],
785− "parameters":[
786− {
787− "name":"status",
788− "in":"query",
789− "description":"Status values that need to be considered for filter",
790− "required":true,
791− "type":"array",
792− "items":{
793− "type":"string",
794− "enum":[
795− "available",
796− "pending",
797− "sold"
798− ],
799− "default":"available"
800− },
801− "collectionFormat":"csv"
802− }
803− ],
804− "responses":{
805− "200":{
806− "description":"successful operation",
807− "schema":{
808− "type":"array",
809− "items":{
810− "$ref":"#/definitions/Pet"
811− }
812− }
813− },
814− "400":{
815− "description":"Invalid status value"
816− }
817− },
818− "security":[
819− {
820− "petstore_auth":[
821− "write:pets",
822− "read:pets"
823− ]
824− }
825− ]
826− }
827− },
828− "/pet/findByTags":{
829− "get":{
830− "tags":[
831− "pet"
832− ],
833− "summary":"Finds Pets by tags",
834− "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",
835− "operationId":"findPetsByTags",
836− "produces":[
837− "application/xml",
838− "application/json"
839− ],
840− "parameters":[
841− {
842− "name":"tags",
843− "in":"query",
844− "description":"Tags to filter by",
845− "required":true,
846− "type":"array",
847− "items":{
848− "type":"string"
849− },
850− "collectionFormat":"csv"
851− }
852− ],
853− "responses":{
854− "200":{
855− "description":"successful operation",
856− "schema":{
857− "type":"array",
858− "items":{
859− "$ref":"#/definitions/Pet"
860− }
861− }
862− },
863− "400":{
864− "description":"Invalid tag value"
865− }
866− },
867− "security":[
868− {
869− "petstore_auth":[
870− "write:pets",
871− "read:pets"
872− ]
873− }
874− ]
875− }
876− },
877− "/pet/{petId}":{
878− "get":{
879− "tags":[
880− "pet"
881− ],
882− "summary":"Find pet by ID",
883− "description":"Returns a single pet",
884− "operationId":"getPetById",
885− "produces":[
886− "application/xml",
887− "application/json"
888− ],
889− "parameters":[
890− {
891− "name":"petId",
892− "in":"path",
893− "description":"ID of pet to return",
894− "required":true,
895− "type":"integer",
896− "format":"int64"
897− }
898− ],
899− "responses":{
900− "200":{
901− "description":"successful operation",
902− "schema":{
903− "$ref":"#/definitions/Pet"
904− }
905− },
906− "400":{
907− "description":"Invalid ID supplied"
908− },
909− "404":{
910− "description":"Pet not found"
911− }
912− },
913− "security":[
914− {
915− "api_key": []
916− }
917− ]
918− },
919− "post":{
920− "tags":[
921− "pet"
922− ],
923− "summary":"Updates a pet in the store with form data",
924− "description":"",
925− "operationId":"updatePetWithForm",
926− "consumes":[
927− "application/x-www-form-urlencoded"
928− ],
929− "produces":[
930− "application/xml",
931− "application/json"
932− ],
933− "parameters":[
934− {
935− "name":"petId",
936− "in":"path",
937− "description":"ID of pet that needs to be updated",
938− "required":true,
939− "type":"integer",
940− "format":"int64"
941− },
942− {
943− "name":"name",
944− "in":"formData",
945− "description":"Updated name of the pet",
946− "required":false,
947− "type":"string"
948− },
949− {
950− "name":"status",
951− "in":"formData",
952− "description":"Updated status of the pet",
953− "required":false,
954− "type":"string"
955− }
956− ],
957− "responses":{
958− "405":{
959− "description":"Invalid input"
960− }
961− },
962− "security":[
963− {
964− "petstore_auth":[
965− "write:pets",
966− "read:pets"
967− ]
968− }
969− ]
970− },
971− "delete":{
972− "tags":[
973− "pet"
974− ],
975− "summary":"Deletes a pet",
976− "description":"",
977− "operationId":"deletePet",
978− "produces":[
979− "application/xml",
980− "application/json"
981− ],
982− "parameters":[
983− {
984− "name":"api_key",
985− "in":"header",
986− "required":false,
987− "type":"string"
988− },
989− {
990− "name":"petId",
991− "in":"path",
992− "description":"Pet id to delete",
993− "required":true,
994− "type":"integer",
995− "format":"int64"
996− }
997− ],
998− "responses":{
999− "400":{
1000− "description":"Invalid pet value"
1001− }
1002− },
1003− "security":[
1004− {
1005− "petstore_auth":[
1006− "write:pets",
1007− "read:pets"
1008− ]
1009− }
1010− ]
1011− }
1012− },
1013− "/pet/{petId}/uploadImage":{
1014− "post":{
1015− "tags":[
1016− "pet"
1017− ],
1018− "summary":"uploads an image",
1019− "description":"",
1020− "operationId":"uploadFile",
1021− "consumes":[
1022− "multipart/form-data"
1023− ],
1024− "produces":[
1025− "application/json"
1026− ],
1027− "parameters":[
1028− {
1029− "name":"petId",
1030− "in":"path",
1031− "description":"ID of pet to update",
1032− "required":true,
1033− "type":"integer",
1034− "format":"int64"
1035− },
1036− {
1037− "name":"additionalMetadata",
1038− "in":"formData",
1039− "description":"Additional data to pass to server",
1040− "required":false,
1041− "type":"string"
1042− },
1043− {
1044− "name":"file",
1045− "in":"formData",
1046− "description":"file to upload",
1047− "required":false,
1048− "type":"file"
1049− }
1050− ],
1051− "responses":{
1052− "200":{
1053− "description":"successful operation",
1054− "schema":{
1055− "$ref":"#/definitions/ApiResponse"
1056− }
1057− }
1058− },
1059− "security":[
1060− {
1061− "petstore_auth":[
1062− "write:pets",
1063− "read:pets"
1064− ]
1065− }
1066− ]
1067− }
1068− },
1069− "/store/inventory":{
1070− "get":{
1071− "tags":[
1072− "store"
1073− ],
1074− "summary":"Returns pet inventories by status",
1075− "description":"Returns a map of status codes to quantities",
1076− "operationId":"getInventory",
1077− "produces":[
1078− "application/json"
1079− ],
1080− "parameters": [],
1081− "responses":{
1082− "200":{
1083− "description":"successful operation",
1084− "schema":{
1085− "type":"object",
1086− "additionalProperties":{
1087− "type":"integer",
1088− "format":"int32"
1089− }
1090− }
1091− }
1092− },
1093− "security":[
1094− {
1095− "api_key": []
1096− }
1097− ]
1098− }
1099− },
1100− "/store/order":{
1101− "post":{
1102− "tags":[
1103− "store"
1104− ],
1105− "summary":"Place an order for a pet",
1106− "description":"",
1107− "operationId":"placeOrder",
1108− "produces":[
1109− "application/xml",
1110− "application/json"
1111− ],
1112− "parameters":[
1113− {
1114− "in":"body",
1115− "name":"body",
1116− "description":"order placed for purchasing the pet",
1117− "required":true,
1118− "schema":{
1119− "$ref":"#/definitions/Order"
1120− }
1121− }
1122− ],
1123− "responses":{
1124− "200":{
1125− "description":"successful operation",
1126− "schema":{
1127− "$ref":"#/definitions/Order"
1128− }
1129− },
1130− "400":{
1131− "description":"Invalid Order"
1132− }
1133− }
1134− }
1135− },
1136− "/store/order/{orderId}":{
1137− "get":{
1138− "tags":[
1139− "store"
1140− ],
1141− "summary":"Find purchase order by ID",
1142− "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",
1143− "operationId":"getOrderById",
1144− "produces":[
1145− "application/xml",
1146− "application/json"
1147− ],
1148− "parameters":[
1149− {
1150− "name":"orderId",
1151− "in":"path",
1152− "description":"ID of pet that needs to be fetched",
1153− "required":true,
1154− "type":"integer",
1155− "maximum":5.0,
1156− "minimum":1.0,
1157− "format":"int64"
1158− }
1159− ],
1160− "responses":{
1161− "200":{
1162− "description":"successful operation",
1163− "schema":{
1164− "$ref":"#/definitions/Order"
1165− }
1166− },
1167− "400":{
1168− "description":"Invalid ID supplied"
1169− },
1170− "404":{
1171− "description":"Order not found"
1172− }
1173− }
1174− },
1175− "delete":{
1176− "tags":[
1177− "store"
1178− ],
1179− "summary":"Delete purchase order by ID",
1180− "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",
1181− "operationId":"deleteOrder",
1182− "produces":[
1183− "application/xml",
1184− "application/json"
1185− ],
1186− "parameters":[
1187− {
1188− "name":"orderId",
1189− "in":"path",
1190− "description":"ID of the order that needs to be deleted",
1191− "required":true,
1192− "type":"string",
1193− "minimum":1.0
1194− }
1195− ],
1196− "responses":{
1197− "400":{
1198− "description":"Invalid ID supplied"
1199− },
1200− "404":{
1201− "description":"Order not found"
1202− }
1203− }
1204− }
1205− },
1206− "/user":{
1207− "post":{
1208− "tags":[
1209− "user"
1210− ],
1211− "summary":"Create user",
1212− "description":"This can only be done by the logged in user.",
1213− "operationId":"createUser",
1214− "produces":[
1215− "application/xml",
1216− "application/json"
1217− ],
1218− "parameters":[
1219− {
1220− "in":"body",
1221− "name":"body",
1222− "description":"Created user object",
1223− "required":true,
1224− "schema":{
1225− "$ref":"#/definitions/User"
1226− }
1227− }
1228− ],
1229− "responses":{
1230− "default":{
1231− "description":"successful operation"
1232− }
1233− }
1234− }
1235− },
1236− "/user/createWithArray":{
1237− "post":{
1238− "tags":[
1239− "user"
1240− ],
1241− "summary":"Creates list of users with given input array",
1242− "description":"",
1243− "operationId":"createUsersWithArrayInput",
1244− "produces":[
1245− "application/xml",
1246− "application/json"
1247− ],
1248− "parameters":[
1249− {
1250− "in":"body",
1251− "name":"body",
1252− "description":"List of user object",
1253− "required":true,
1254− "schema":{
1255− "type":"array",
1256− "items":{
1257− "$ref":"#/definitions/User"
1258− }
1259− }
1260− }
1261− ],
1262− "responses":{
1263− "default":{
1264− "description":"successful operation"
1265− }
1266− }
1267− }
1268− },
1269− "/user/createWithList":{
1270− "post":{
1271− "tags":[
1272− "user"
1273− ],
1274− "summary":"Creates list of users with given input array",
1275− "description":"",
1276− "operationId":"createUsersWithListInput",
1277− "produces":[
1278− "application/xml",
1279− "application/json"
1280− ],
1281− "parameters":[
1282− {
1283− "in":"body",
1284− "name":"body",
1285− "description":"List of user object",
1286− "required":true,
1287− "schema":{
1288− "type":"array",
1289− "items":{
1290− "$ref":"#/definitions/User"
1291− }
1292− }
1293− }
1294− ],
1295− "responses":{
1296− "default":{
1297− "description":"successful operation"
1298− }
1299− }
1300− }
1301− },
1302− "/user/login":{
1303− "get":{
1304− "tags":[
1305− "user"
1306− ],
1307− "summary":"Logs user into the system",
1308− "description":"",
1309− "operationId":"loginUser",
1310− "produces":[
1311− "application/xml",
1312− "application/json"
1313− ],
1314− "parameters":[
1315− {
1316− "name":"username",
1317− "in":"query",
1318− "description":"The user name for login",
1319− "required":true,
1320− "type":"string"
1321− },
1322− {
1323− "name":"password",
1324− "in":"query",
1325− "description":"The password for login in clear text",
1326− "required":true,
1327− "type":"string"
1328− }
1329− ],
1330− "responses":{
1331− "200":{
1332− "description":"successful operation",
1333− "schema":{
1334− "type":"string"
1335− },
1336− "headers":{
1337− "X-Rate-Limit":{
1338− "type":"integer",
1339− "format":"int32",
1340− "description":"calls per hour allowed by the user"
1341− },
1342− "X-Expires-After":{
1343− "type":"string",
1344− "format":"date-time",
1345− "description":"date in UTC when toekn expires"
1346− }
1347− }
1348− },
1349− "400":{
1350− "description":"Invalid username/password supplied"
1351− }
1352− }
1353− }
1354− },
1355− "/user/logout":{
1356− "get":{
1357− "tags":[
1358− "user"
1359− ],
1360− "summary":"Logs out current logged in user session",
1361− "description":"",
1362− "operationId":"logoutUser",
1363− "produces":[
1364− "application/xml",
1365− "application/json"
1366− ],
1367− "parameters": [],
1368− "responses":{
1369− "default":{
1370− "description":"successful operation"
1371− }
1372− }
1373− }
1374− },
1375− "/user/{username}":{
1376− "get":{
1377− "tags":[
1378− "user"
1379− ],
1380− "summary":"Get user by user name",
1381− "description":"",
1382− "operationId":"getUserByName",
1383− "produces":[
1384− "application/xml",
1385− "application/json"
1386− ],
1387− "parameters":[
1388− {
1389− "name":"username",
1390− "in":"path",
1391− "description":"The name that needs to be fetched. Use user1 for testing. ",
1392− "required":true,
1393− "type":"string"
1394− }
1395− ],
1396− "responses":{
1397− "200":{
1398− "description":"successful operation",
1399− "schema":{
1400− "$ref":"#/definitions/User"
1401− }
1402− },
1403− "400":{
1404− "description":"Invalid username supplied"
1405− },
1406− "404":{
1407− "description":"User not found"
1408− }
1409− }
1410− },
1411− "put":{
1412− "tags":[
1413− "user"
1414− ],
1415− "summary":"Updated user",
1416− "description":"This can only be done by the logged in user.",
1417− "operationId":"updateUser",
1418− "produces":[
1419− "application/xml",
1420− "application/json"
1421− ],
1422− "parameters":[
1423− {
1424− "name":"username",
1425− "in":"path",
1426− "description":"name that need to be deleted",
1427− "required":true,
1428− "type":"string"
1429− },
1430− {
1431− "in":"body",
1432− "name":"body",
1433− "description":"Updated user object",
1434− "required":true,
1435− "schema":{
1436− "$ref":"#/definitions/User"
1437− }
1438− }
1439− ],
1440− "responses":{
1441− "400":{
1442− "description":"Invalid user supplied"
1443− },
1444− "404":{
1445− "description":"User not found"
1446− }
1447− }
1448− },
1449− "delete":{
1450− "tags":[
1451− "user"
1452− ],
1453− "summary":"Delete user",
1454− "description":"This can only be done by the logged in user.",
1455− "operationId":"deleteUser",
1456− "produces":[
1457− "application/xml",
1458− "application/json"
1459− ],
1460− "parameters":[
1461− {
1462− "name":"username",
1463− "in":"path",
1464− "description":"The name that needs to be deleted",
1465− "required":true,
1466− "type":"string"
1467− }
1468− ],
1469− "responses":{
1470− "400":{
1471− "description":"Invalid username supplied"
1472− },
1473− "404":{
1474− "description":"User not found"
1475− }
1476− }
1477− }
1478− }
1479− },
1480− "securityDefinitions":{
1481− "petstore_auth":{
1482− "type":"oauth2",
1483− "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",
1484− "flow":"implicit",
1485− "scopes":{
1486− "write:pets":"modify pets in your account",
1487− "read:pets":"read your pets"
1488− }
1489− },
1490− "api_key":{
1491− "type":"apiKey",
1492− "name":"api_key",
1493− "in":"header"
1494− }
1495− },
1496− "definitions":{
1497− "Order":{
1498− "type":"object",
1499− "properties":{
1500− "id":{
1501− "type":"integer",
1502− "format":"int64"
1503− },
1504− "petId":{
1505− "type":"integer",
1506− "format":"int64"
1507− },
1508− "quantity":{
1509− "type":"integer",
1510− "format":"int32"
1511− },
1512− "shipDate":{
1513− "type":"string",
1514− "format":"date-time"
1515− },
1516− "status":{
1517− "type":"string",
1518− "description":"Order Status",
1519− "enum":[
1520− "placed",
1521− "approved",
1522− "delivered"
1523− ]
1524− },
1525− "complete":{
1526− "type":"boolean",
1527− "default":false
1528− }
1529− },
1530− "xml":{
1531− "name":"Order"
1532− }
1533− },
1534− "Category":{
1535− "type":"object",
1536− "properties":{
1537− "id":{
1538− "type":"integer",
1539− "format":"int64"
1540− },
1541− "name":{
1542− "type":"string"
1543− }
1544− },
1545− "xml":{
1546− "name":"Category"
1547− }
1548− },
1549− "User":{
1550− "type":"object",
1551− "properties":{
1552− "id":{
1553− "type":"integer",
1554− "format":"int64"
1555− },
1556− "username":{
1557− "type":"string"
1558− },
1559− "firstName":{
1560− "type":"string"
1561− },
1562− "lastName":{
1563− "type":"string"
1564− },
1565− "email":{
1566− "type":"string"
1567− },
1568− "password":{
1569− "type":"string"
1570− },
1571− "phone":{
1572− "type":"string"
1573− },
1574− "userStatus":{
1575− "type":"integer",
1576− "format":"int32",
1577− "description":"User Status"
1578− }
1579− },
1580− "xml":{
1581− "name":"User"
1582− }
1583− },
1584− "Tag":{
1585− "type":"object",
1586− "properties":{
1587− "id":{
1588− "type":"integer",
1589− "format":"int64"
1590− },
1591− "name":{
1592− "type":"string"
1593− }
1594− },
1595− "xml":{
1596− "name":"Tag"
1597− }
1598− },
1599− "Pet":{
1600− "type":"object",
1601− "required":[
1602− "name",
1603− "photoUrls"
1604− ],
1605− "properties":{
1606− "id":{
1607− "type":"integer",
1608− "format":"int64"
1609− },
1610− "category":{
1611− "$ref":"#/definitions/Category"
1612− },
1613− "name":{
1614− "type":"string",
1615− "example":"doggie"
1616− },
1617− "photoUrls":{
1618− "type":"array",
1619− "xml":{
1620− "name":"photoUrl",
1621− "wrapped":true
1622− },
1623− "items":{
1624− "type":"string"
1625− }
1626− },
1627− "tags":{
1628− "type":"array",
1629− "xml":{
1630− "name":"tag",
1631− "wrapped":true
1632− },
1633− "items":{
1634− "$ref":"#/definitions/Tag"
1635− }
1636− },
1637− "status":{
1638− "type":"string",
1639− "description":"pet status in the store",
1640− "enum":[
1641− "available",
1642− "pending",
1643− "sold"
1644− ]
1645− }
1646− },
1647− "xml":{
1648− "name":"Pet"
1649− }
1650− },
1651− "ApiResponse":{
1652− "type":"object",
1653− "properties":{
1654− "code":{
1655− "type":"integer",
1656− "format":"int32"
1657− },
1658− "type":{
1659− "type":"string"
1660− },
1661− "message":{
1662− "type":"string"
1663− }
1664− }
1665− }
1666− },
1667− "externalDocs":{
1668− "description":"Find out more about Swagger",
1669− "url":"http://swagger.io"
1670− }
1671−}
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/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
test/SpecCommon.hsdeleted−30
@@ -1,30 +0,0 @@
1−module SpecCommon where
2−
3−import Data.Aeson
4−import Data.ByteString.Builder (toLazyByteString)
5−import qualified Data.Foldable as F
6−import qualified Data.HashMap.Strict as HashMap
7−import qualified Data.Vector as Vector
8−
9−import Test.Hspec
10−
11−isSubJSON :: Value -> Value -> Bool
12−isSubJSON Null _ = True
13−isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i
14− where
15− i = HashMap.intersectionWith isSubJSON x y
16−isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys)
17−isSubJSON x y = x == y
18−
19−(<=>) :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Value -> Spec
20−x <=> js = do
21− it "encodes correctly" $ do
22− toJSON x `shouldBe` js
23− it "decodes correctly" $ do
24− fromJSON js `shouldBe` Success x
25− it "roundtrips: eitherDecode . encode" $ do
26− eitherDecode (encode x) `shouldBe` Right x
27− it "roundtrips with toJSON" $ do
28− eitherDecode (encode $ toJSON x) `shouldBe` Right x
29− it "roundtrips with toEncoding" $ do
30− eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x
test/doctests.hsdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−import Build_doctests (flags, pkgs, module_sources)
4−import Data.Foldable (traverse_)
5−import Test.DocTest
6−
7−main :: IO ()
8−main = do
9− traverse_ putStrLn args
10− doctest args
11− where
12− args = flags ++ pkgs ++ module_sources