git.iko.soy/typeable/swagger2
on 006bdb0 help sign in
38 files changed+1249−4069
since splitsnapshots
unifiedsplit
.ghci+1−2 .gitignore−2 .travis.yml+67−150 CHANGELOG.md−156 LICENSE+1−1 README.md+1−3 Setup.hs−31 cabal.project−2 examples/hackage.hs+1−15 hackage-docs.sh−78 src/Data/Swagger.hs+6−68 src/Data/Swagger/Declare.hs+5−77 src/Data/Swagger/Internal.hs+135−373 src/Data/Swagger/Internal/AesonUtils.hs−346 src/Data/Swagger/Internal/ParamSchema.hs+26−95 src/Data/Swagger/Internal/Schema.hs+105−280 src/Data/Swagger/Internal/Schema/Validation.hs+77−264 src/Data/Swagger/Internal/TypeShape.hs−66 src/Data/Swagger/Internal/Utils.hs+46−6 src/Data/Swagger/Lens.hs+9−20 src/Data/Swagger/Operation.hs+19−18 src/Data/Swagger/Optics.hs−597 src/Data/Swagger/Schema.hs−15 src/Data/Swagger/Schema/Generator.hs−114 src/Data/Swagger/Schema/Validation.hs+1−10 src/Data/Swagger/SchemaOptions.hs−29 stack-lts-2.yaml+5 stack.yaml+3−7 swagger2.cabal+41−99 test/Data/Swagger/CommonTestTypes.hs−679 test/Data/Swagger/ParamSchemaSpec.hs+84−10 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs+65−130 test/Data/Swagger/SchemaSpec.hs+513−25 test/Data/SwaggerSpec.hs+28−114 test/DocTest.hs+8 test/SpecCommon.hs+2−7 test/doctests.hs−12
.ghci+1−2
@@ -1,2 +1 @@
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
1+:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.22.5.0/build/autogen/cabal_macros.h -optP-I -optPinclude
.gitignore−2
@@ -1,6 +1,4 @@
11dist
2−dist-newstyle
3−.ghc.environment.*
42cabal-dev
53*.o
64*.hi
.travis.yml+67−150
@@ -1,162 +1,79 @@
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−#
1+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
92language: c
10−dist: xenial
11−git:
12− # whether to recursively clone submodules
13− submodules: false
14−branches:
15− only:
16− - master
3+sudo: false
4+
175cache:
186 directories:
7+ - $HOME/.cabsnap
198 - $HOME/.cabal/packages
20− - $HOME/.cabal/store
9+
2110before_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
11+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
12+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
13+
3014matrix:
3115 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"]}}
16+ - env: CABALVER=1.18 GHCVER=7.8.4
17+ compiler: ": #GHC 7.8.4"
18+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5], sources: [hvr-ghc]}}
19+ - env: CABALVER=1.22 GHCVER=7.10.3
20+ compiler: ": #GHC 7.10.3"
21+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5], sources: [hvr-ghc]}}
22+
4223before_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
24+ - unset CC
25+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/1.19.5/bin:$PATH
26+
7427install:
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
28+ - cabal --version
29+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
30+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
31+ then
32+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
33+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
34+ fi
35+ - travis_retry cabal update -v
36+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
37+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
38+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
39+
40+# check whether current requested install-plan matches cached package-db snapshot
41+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
42+ then
43+ echo "cabal build-cache HIT";
44+ rm -rfv .ghc;
45+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
46+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
47+ else
48+ echo "cabal build-cache MISS";
49+ rm -rf $HOME/.cabsnap;
50+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
51+ cabal install --only-dependencies --enable-tests --enable-benchmarks;
52+ fi
53+
54+# snapshot package-db on cache miss
55+ - if [ ! -d $HOME/.cabsnap ];
56+ then
57+ echo "snapshotting package-db to build-cache";
58+ mkdir $HOME/.cabsnap;
59+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
60+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
61+ fi
62+
63+# Here starts the actual work to be performed for the package under test;
64+# any command which exits with a non-zero exit code causes the build to fail.
12665script:
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
66+ - if [ -f configure.ac ]; then autoreconf -i; fi
67+ - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
68+ - cabal build # this builds all libraries and executables (including tests/benchmarks)
69+ - cabal test
70+ - cabal check
71+ - cabal sdist # tests that a source-distribution can be generated
72+
73+# Check that the resulting source distribution can be built & installed.
74+# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
75+# `cabal install --force-reinstalls dist/*-*.tar.gz`
76+ - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
77+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
16078
161−# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
16279# EOF
CHANGELOG.md−156
@@ -1,159 +1,3 @@
1−2.5
2−---
3−
4−Highlights:
5−- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));
6−- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));
7−- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));
8−
9−Fixes and minor changes:
10−- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));
11−- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));
12−- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));
13−
14−2.4
15−---
16−
17−- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5
18−- Tags aren't sorted
19− (see [#165](https://github.com/GetShopTV/swagger2/issues/165))
20−- Schema type is optional
21− (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))
22−- Take concrete 'Proxy' as argument
23− (see [#180](https://github.com/GetShopTV/swagger2/pull/180))
24−- GHC-8.8 preparations
25−
26−2.3.1.1
27−-------
28−
29−- Allow `network-3.0`
30−
31−2.3.1
32−-----
33−
34−- Add a quickcheck generator for aeson Values that match a swagger schema
35− (see [#162](https://github.com/GetShopTV/swagger2/pull/162))
36−- Add `ToParamSchema` instance for `SetCookie`
37− (see [#173](https://github.com/GetShopTV/swagger2/pull/173))
38−- Make nullary schemas valid
39− (see [#168](https://github.com/GetShopTV/swagger2/pull/168))
40−
41−2.3.0.1
42−-------
43−
44−- Support GHC-8.6
45−
46−2.3
47−---
48−
49−Major changes:
50−
51−- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));
52−- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));
53−
54−Dependencies and CI:
55−
56−- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));
57−- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));
58−- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));
59−- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));
60−
61−2.2.2
62−-----
63−
64−* Add `ToSchema Version` instance
65−* Use base-compat-batteries (0.10)
66−* PVP bounds
67−
68−2.2.1
69−-----
70−
71−* Add `Semigroup` instances
72−* GHC-8.4 compatibility
73−* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))
74−* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))
75−* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))
76−* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))
77−
78−2.2
79−---
80−
81−* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
82−* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
83−* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):
84− * `genericNameSchema` — to give a custom schema `Generic`-based name;
85− * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;
86− * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;
87−* Add a few tests with invalid `Schema`.
88−
89−2.1.6
90−-----
91−
92−* Add `ToParamSchema` and `ToSchema` instances for `Fixed` (see [#121](https://github.com/GetShopTV/swagger2/pull/121)) and `Natural` (see [#123](https://github.com/GetShopTV/swagger2/pull/123));
93−* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));
94−* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).
95−
96−2.1.5
97−-----
98−
99−* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));
100−* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));
101−* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));
102−* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).
103−
104−2.1.4.1
105−-------
106−
107−* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108));
108−* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));
109−* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));
110−* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).
111−
112−2.1.4
113−-----
114−
115−* Add `liftDeclare` (see [#100](https://github.com/GetShopTV/swagger2/pull/100));
116−* Add `MonadDeclare` instances for all monad transformers (see [#100](https://github.com/GetShopTV/swagger2/pull/100)).
117−
118−2.1.3
119−-----
120−
121−* Add [`UUID`](http://hackage.haskell.org/package/uuid-types/docs/Data-UUID-Types.html#t:UUID) instances (see [#81](https://github.com/GetShopTV/swagger2/pull/81)).
122−* Add [`TypeError`](https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-TypeLits.html#g:4) `ToSchema` and `ToParamSchema ByteString` instances (see [#78](https://github.com/GetShopTV/swagger2/pull/78))
123−* Improve documentation for generic sum type instance derivation (see [#75](https://github.com/GetShopTV/swagger2/pull/75))
124−* Compile warning free (see [#82](https://github.com/GetShopTV/swagger2/pull/82))
125−
126−2.1.2.1
127−-------
128−
129−* Bug fix previous release
130−
131−2.1.2
132−---
133−
134−* Minor changes:
135− * Support `aeson-1.0.0.0` (see [#70](https://github.com/GetShopTV/swagger2/pull/70)).
136−
137−2.1.1
138−---
139−
140−* Minor changes:
141− * Proper `Schema` examples for `Char`, `Day`, `LocalTime`, `ZonedTime` and `UTCTime`.
142−
143−2.1
144−---
145−
146−* Major changes:
147− * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));
148− * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).
149−
150−2.0.2
151−---
152−
153−* Fixes:
154− * Fix `additionalProperties` to allow references;
155− * Fix `ToSchema` instances for `Map` and `HashMap` (prevent infinite recursion for recursive values).
156−
15712.0.1
1582---
1593
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015-2016, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
README.md+1−3
@@ -1,7 +1,5 @@
11# swagger2
22
3−[![Join the chat at https://gitter.im/haskell-swagger2/Lobby](https://badges.gitter.im/haskell-swagger2/Lobby.svg)](https://gitter.im/haskell-swagger2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
4−
53[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
64[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
75[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
@@ -13,7 +11,7 @@ The original Swagger 2.0 specification is available at http://swagger.io/specifi
1311
1412## Usage
1513
16−This library is intended to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
14+This library is inteded to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.
1715
1816Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).
1917
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.hs+1−15
@@ -20,21 +20,7 @@ type Username = Text
2020data UserSummary = UserSummary
2121 { summaryUsername :: Username
2222 , 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−
23+ } deriving (Generic, ToSchema)
3824
3925type Group = Text
4026
hackage-docs.shdeleted−78
@@ -1,78 +0,0 @@
1−#!/bin/bash
2−set -e
3−
4−# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5−
6−if [ "$#" -ne 1 ]; then
7− echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8− exit 1
9−fi
10−
11−user=$1
12−
13−cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14−if [ ! -f "$cabal_file" ]; then
15− echo "Run this script in the top-level package directory"
16− exit 1
17−fi
18−
19−pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20−ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21−
22−if [ -z "$pkg" ]; then
23− echo "Unable to determine package name"
24− exit 1
25−fi
26−
27−if [ -z "$ver" ]; then
28− echo "Unable to determine package version"
29− exit 1
30−fi
31−
32−echo "Detected package: $pkg-$ver"
33−
34−dir=$(mktemp -d build-docs.XXXXXX)
35−trap 'rm -r "$dir"' EXIT
36−
37−export PATH=$(stack path --bin-path)
38−
39−ghc --version
40−cabal --version
41−stack --version
42−
43−if haddock --hyperlinked-source >/dev/null
44−then
45− echo "Using fancy hyperlinked source"
46− HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47−else
48− echo "Using boring hyperlinked source"
49− HYPERLINK_FLAG="--hyperlink-source"
50−fi
51−
52−# Cabal dist in temporary location
53−builddir=$dir/dist
54−
55−# Build dependencies haddocks with stack, so we get links
56−stack haddock --only-dependencies
57−
58−# Configure using stack databases
59−snapshotpkgdb=$(stack path --snapshot-pkg-db)
60−localpkgdb=$(stack path --local-pkg-db)
61−cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62−
63−# Build Hadckage compatible docs
64−cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65−
66−# Copy into right directory
67−cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68−
69−# Tar and gzip
70−tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71−
72−# Upload
73−curl -X PUT \
74− -H 'Content-Type: application/x-tar' \
75− -H 'Content-Encoding: gzip' \
76− -u "$user" \
77− --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78− "https://hackage.haskell.org/package/$pkg-$ver/docs"
src/Data/Swagger.hs+6−68
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
21-- |
32-- Module: Data.Swagger
43-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -31,7 +30,6 @@ module Data.Swagger (
3130
3231 -- * Re-exports
3332 module Data.Swagger.Lens,
34− module Data.Swagger.Optics,
3533 module Data.Swagger.Operation,
3634 module Data.Swagger.ParamSchema,
3735 module Data.Swagger.Schema,
@@ -78,7 +76,6 @@ module Data.Swagger (
7876 SwaggerItems(..),
7977 Xml(..),
8078 Pattern,
81− AdditionalProperties(..),
8279
8380 -- ** Responses
8481 Responses(..),
@@ -89,7 +86,6 @@ module Data.Swagger (
8986 SecurityScheme(..),
9087 SecuritySchemeType(..),
9188 SecurityRequirement(..),
92− SecurityDefinitions(..),
9389
9490 -- *** API key
9591 ApiKeyParams(..),
@@ -114,7 +110,6 @@ module Data.Swagger (
114110) where
115111
116112import Data.Swagger.Lens
117−import Data.Swagger.Optics ()
118113import Data.Swagger.Operation
119114import Data.Swagger.ParamSchema
120115import Data.Swagger.Schema
@@ -178,22 +173,20 @@ import Data.Swagger.Internal
178173
179174-- $lens
180175--
181−-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182−--
183176-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
184177-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
185178-- make it fairly simple to construct/modify any part of the specification:
186179--
187180-- >>> :{
188181-- encode $ (mempty :: Swagger)
189−-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
182+-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
190183-- & paths .~
191184-- [ ("/user", mempty & get ?~ (mempty
192185-- & produces ?~ MimeList ["application/json"]
193186-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))
194187-- & at 404 ?~ "User info not found")) ]
195188-- :}
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\"}}}"
189+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"produces\":[\"application/json\"]}}}}"
197190--
198191-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
199192-- which produces @application/json@ output. It should respond with code @200@ and body specified
@@ -209,16 +202,16 @@ import Data.Swagger.Internal
209202-- "{\"description\":\"No content\"}"
210203-- >>> :{
211204-- encode $ (mempty :: Schema)
212−-- & type_ ?~ SwaggerBoolean
205+-- & type_ .~ SwaggerBoolean
213206-- & description ?~ "To be or not to be"
214207-- :}
215−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
208+-- "{\"type\":\"boolean\",\"description\":\"To be or not to be\"}"
216209--
217210-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).
218211-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
219212-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
220213--
221−-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
214+-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
222215-- "{\"type\":\"number\"}"
223216--
224217-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
@@ -278,62 +271,7 @@ import Data.Swagger.Internal
278271-- >>> encode (Person "David" 28)
279272-- "{\"age\":28,\"name\":\"David\"}"
280273-- >>> 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−--
274+-- "{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}}"
337275
338276-- $manipulation
339277-- Sometimes you have to work with an imported or generated @'Swagger'@.
src/Data/Swagger/Declare.hs+5−77
@@ -2,7 +2,6 @@
22{-# LANGUAGE FlexibleInstances #-}
33{-# LANGUAGE FunctionalDependencies #-}
44{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE UndecidableInstances #-}
65-- |
76-- Module: Data.Swagger.Declare
87-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -15,20 +14,9 @@ import Prelude ()
1514import Prelude.Compat
1615
1716import Control.Monad
18−import Control.Monad.Cont (ContT)
19−import Control.Monad.List (ListT)
20−import Control.Monad.Reader (ReaderT)
2117import 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
3118import Data.Functor.Identity
19+import Data.Monoid
3220
3321-- | A declare monad transformer parametrized by:
3422--
@@ -49,15 +37,15 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
4937 pure x = DeclareT (\_ -> pure (mempty, x))
5038 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
5139 ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
53− return (mappend d' d'', f x)
40+ ~(d'', x) <- dx (d <> d')
41+ return (d' <> d'', f x)
5442
5543instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
5644 return x = DeclareT (\_ -> pure (mempty, x))
5745 DeclareT dx >>= f = DeclareT $ \d -> do
5846 ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
60− return (mappend d' d'', y)
47+ ~(d'', y) <- runDeclareT (f x) (d <> d')
48+ return (d' <> d'', y)
6149
6250instance Monoid d => MonadTrans (DeclareT d) where
6351 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
@@ -89,13 +77,6 @@ instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) whe
8977 declare d = DeclareT (\_ -> return (d, ()))
9078 look = DeclareT (\d -> return (mempty, d))
9179
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−
9980-- | Retrieve a function of all the output so far.
10081looks :: MonadDeclare d m => (d -> a) -> m a
10182looks f = f <$> look
@@ -144,56 +125,3 @@ execDeclare m = runIdentity . execDeclareT m
144125undeclare :: Monoid d => Declare d a -> a
145126undeclare = runIdentity . undeclareT
146127
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+135−373
@@ -1,5 +1,4 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
32{-# LANGUAGE DeriveDataTypeable #-}
43{-# LANGUAGE DeriveFunctor #-}
54{-# LANGUAGE DeriveGeneric #-}
@@ -12,66 +11,37 @@
1211{-# LANGUAGE RecordWildCards #-}
1312{-# LANGUAGE ScopedTypeVariables #-}
1413{-# LANGUAGE StandaloneDeriving #-}
15−{-# LANGUAGE TemplateHaskell #-}
16−{-# LANGUAGE TypeFamilies #-}
1714{-# LANGUAGE UndecidableInstances #-}
18−#if __GLASGOW_HASKELL__ <710
19−{-# LANGUAGE PolyKinds #-}
20−#endif
2115#include "overlapping-compat.h"
2216module Data.Swagger.Internal where
2317
2418import Prelude ()
2519import Prelude.Compat
2620
27−import Control.Lens ((&), (.~), (?~))
2821import Control.Applicative
22+import Control.Monad
2923import Data.Aeson
3024import qualified Data.Aeson.Types as JSON
3125import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32−import Data.Hashable (Hashable)
26+import Data.HashMap.Strict (HashMap)
3327import qualified Data.HashMap.Strict as HashMap
34−import Data.HashSet.InsOrd (InsOrdHashSet)
3528import Data.Map (Map)
3629import qualified Data.Map as Map
37−import Data.Monoid (Monoid (..))
38−import Data.Semigroup.Compat (Semigroup (..))
30+import Data.Monoid
3931import Data.Scientific (Scientific)
32+import Data.Set (Set)
4033import Data.String (IsString(..))
4134import Data.Text (Text)
4235import qualified Data.Text as Text
4336import GHC.Generics (Generic)
44−import Network.Socket (HostName, PortNumber)
37+import Network (HostName, PortNumber)
4538import Network.HTTP.Media (MediaType)
4639import Text.Read (readMaybe)
4740
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)
6041import Data.Swagger.Internal.Utils
6142
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−
7343-- | A list of definitions that can be used in references.
74−type Definitions = InsOrdHashMap Text
44+type Definitions = HashMap Text
7545
7646-- | This is the root document object for the API specification.
7747data Swagger = Swagger
@@ -103,7 +73,7 @@ data Swagger = Swagger
10373 -- | The available paths and operations for the API.
10474 -- Holds the relative paths to the individual endpoints.
10575 -- The path is appended to the @'basePath'@ in order to construct the full URL.
106− , _swaggerPaths :: InsOrdHashMap FilePath PathItem
76+ , _swaggerPaths :: HashMap FilePath PathItem
10777
10878 -- | An object to hold data types produced and consumed by operations.
10979 , _swaggerDefinitions :: Definitions Schema
@@ -117,7 +87,7 @@ data Swagger = Swagger
11787 , _swaggerResponses :: Definitions Response
11888
11989 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: SecurityDefinitions
90+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme
12191
12292 -- | A declaration of which security schemes are applied for the API as a whole.
12393 -- The list of values describes alternative security schemes that can be used
@@ -130,7 +100,7 @@ data Swagger = Swagger
130100 -- Not all tags that are used by the Operation Object must be declared.
131101 -- The tags that are not declared may be organized randomly or based on the tools' logic.
132102 -- Each tag name in the list MUST be unique.
133− , _swaggerTags :: InsOrdHashSet Tag
103+ , _swaggerTags :: Set Tag
134104
135105 -- | Additional external documentation.
136106 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -252,7 +222,7 @@ data PathItem = PathItem
252222data Operation = Operation
253223 { -- | A list of tags for API documentation control.
254224 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
255− _operationTags :: InsOrdHashSet TagName
225+ _operationTags :: Set TagName
256226
257227 -- | A short summary of what the operation does.
258228 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -309,7 +279,7 @@ data Operation = Operation
309279 } deriving (Eq, Show, Generic, Data, Typeable)
310280
311281newtype MimeList = MimeList { getMimeList :: [MediaType] }
312− deriving (Eq, Show, Semigroup, Monoid, Typeable)
282+ deriving (Eq, Show, Monoid, Typeable)
313283
314284mimeListConstr :: Constr
315285mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -360,8 +330,8 @@ data ParamOtherSchema = ParamOtherSchema
360330 -- Default value is @False@.
361331 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool
362332
363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema
364− } deriving (Eq, Show, Generic, Typeable, Data)
333+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema
334+ } deriving (Eq, Show, Generic, Data, Typeable)
365335
366336-- | Items for @'SwaggerArray'@ schemas.
367337--
@@ -374,9 +344,9 @@ data ParamOtherSchema = ParamOtherSchema
374344--
375345-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.
376346data SwaggerItems t where
377− SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k
378− SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema
379− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema
347+ SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t
348+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema
349+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema
380350 deriving (Typeable)
381351
382352deriving instance Eq (SwaggerItems t)
@@ -386,66 +356,17 @@ deriving instance Show (SwaggerItems t)
386356swaggerItemsPrimitiveConstr :: Constr
387357swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix
388358
389−swaggerItemsObjectConstr :: Constr
390−swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix
391−
392−swaggerItemsArrayConstr :: Constr
393−swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix
394−
395359swaggerItemsDataType :: DataType
396360swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]
397361
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
362+instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where
403363 gunfold k z c = case constrIndex c of
404364 1 -> k (k (z SwaggerItemsPrimitive))
405365 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."
406366 toConstr _ = swaggerItemsPrimitiveConstr
407367 dataTypeOf _ = swaggerItemsDataType
408368
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
369+deriving instance Data (SwaggerItems Schema)
449370
450371data SwaggerType t where
451372 SwaggerString :: SwaggerType t
@@ -453,9 +374,9 @@ data SwaggerType t where
453374 SwaggerInteger :: SwaggerType t
454375 SwaggerBoolean :: SwaggerType t
455376 SwaggerArray :: SwaggerType t
456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema
457− SwaggerNull :: SwaggerType 'SwaggerKindSchema
458− SwaggerObject :: SwaggerType 'SwaggerKindSchema
377+ SwaggerFile :: SwaggerType ParamOtherSchema
378+ SwaggerNull :: SwaggerType Schema
379+ SwaggerObject :: SwaggerType Schema
459380 deriving (Typeable)
460381
461382deriving instance Eq (SwaggerType t)
@@ -464,33 +385,33 @@ deriving instance Show (SwaggerType t)
464385swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr
465386swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix
466387
467−swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType
388+swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType
468389swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs
469390
470−swaggerCommonTypes :: [SwaggerType k]
391+swaggerCommonTypes :: [SwaggerType t]
471392swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]
472393
473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]
394+swaggerParamTypes :: [SwaggerType ParamOtherSchema]
474395swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]
475396
476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]
397+swaggerSchemaTypes :: [SwaggerType Schema]
477398swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]
478399
479400swaggerTypeConstrs :: [Constr]
480−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])
401+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])
481402 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]
482403
483−instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where
404+instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where
484405 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes
485406 toConstr = swaggerTypeConstr
486407 dataTypeOf = swaggerTypeDataType
487408
488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where
409+instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where
489410 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes
490411 toConstr = swaggerTypeConstr
491412 dataTypeOf = swaggerTypeDataType
492413
493−instance Data (SwaggerType 'SwaggerKindSchema) where
414+instance OVERLAPPABLE_ Data (SwaggerType Schema) where
494415 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes
495416 toConstr = swaggerTypeConstr
496417 dataTypeOf = swaggerTypeDataType
@@ -530,7 +451,7 @@ data CollectionFormat t where
530451 -- Corresponds to multiple parameter instances
531452 -- instead of multiple values for a single instance @foo=bar&foo=baz@.
532453 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.
533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema
454+ CollectionMulti :: CollectionFormat ParamOtherSchema
534455 deriving (Typeable)
535456
536457deriving instance Eq (CollectionFormat t)
@@ -546,12 +467,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $
546467collectionCommonFormats :: [CollectionFormat t]
547468collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]
548469
549−instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where
470+instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where
550471 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats
551472 toConstr = collectionFormatConstr
552473 dataTypeOf _ = collectionFormatDataType
553474
554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)
475+deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)
555476
556477type ParamName = Text
557478
@@ -560,9 +481,9 @@ data Schema = Schema
560481 , _schemaDescription :: Maybe Text
561482 , _schemaRequired :: [ParamName]
562483
563− , _schemaAllOf :: Maybe [Referenced Schema]
564− , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565− , _schemaAdditionalProperties :: Maybe AdditionalProperties
484+ , _schemaAllOf :: Maybe [Schema]
485+ , _schemaProperties :: HashMap Text (Referenced Schema)
486+ , _schemaAdditionalProperties :: Maybe Schema
566487
567488 , _schemaDiscriminator :: Maybe Text
568489 , _schemaReadOnly :: Maybe Bool
@@ -573,7 +494,7 @@ data Schema = Schema
573494 , _schemaMaxProperties :: Maybe Integer
574495 , _schemaMinProperties :: Maybe Integer
575496
576− , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema
497+ , _schemaParamSchema :: ParamSchema Schema
577498 } deriving (Eq, Show, Generic, Data, Typeable)
578499
579500-- | A @'Schema'@ with an optional name.
@@ -586,7 +507,7 @@ data NamedSchema = NamedSchema
586507-- | Regex pattern for @string@ type.
587508type Pattern = Text
588509
589−data ParamSchema (t :: SwaggerKind *) = ParamSchema
510+data ParamSchema t = ParamSchema
590511 { -- | Declares the value of the parameter that the server will use if none is provided,
591512 -- for example a @"count"@ to control the number of results per page might default to @100@
592513 -- if not supplied by the client in the request.
@@ -594,7 +515,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
594515 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
595516 _paramSchemaDefault :: Maybe Value
596517
597− , _paramSchemaType :: Maybe (SwaggerType t)
518+ , _paramSchemaType :: SwaggerType t
598519 , _paramSchemaFormat :: Maybe Format
599520 , _paramSchemaItems :: Maybe (SwaggerItems t)
600521 , _paramSchemaMaximum :: Maybe Scientific
@@ -611,7 +532,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
611532 , _paramSchemaMultipleOf :: Maybe Scientific
612533 } deriving (Eq, Show, Generic, Typeable)
613534
614−deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
535+deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)
615536
616537data Xml = Xml
617538 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -653,7 +574,7 @@ data Responses = Responses
653574
654575 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).
655576 -- Describes the expected response for those HTTP status codes.
656− , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)
577+ , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)
657578 } deriving (Eq, Show, Generic, Data, Typeable)
658579
659580type HttpStatusCode = Int
@@ -672,7 +593,7 @@ data Response = Response
672593 , _responseSchema :: Maybe (Referenced Schema)
673594
674595 -- | A list of headers that are sent with the response.
675− , _responseHeaders :: InsOrdHashMap HeaderName Header
596+ , _responseHeaders :: HashMap HeaderName Header
676597
677598 -- | An example of the response message.
678599 , _responseExamples :: Maybe Example
@@ -687,7 +608,7 @@ data Header = Header
687608 { -- | A short description of the header.
688609 _headerDescription :: Maybe Text
689610
690− , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)
611+ , _headerParamSchema :: ParamSchema Header
691612 } deriving (Eq, Show, Generic, Data, Typeable)
692613
693614data Example = Example { getExample :: Map MediaType Value }
@@ -738,7 +659,7 @@ data OAuth2Params = OAuth2Params
738659 _oauth2Flow :: OAuth2Flow
739660
740661 -- | The available scopes for the OAuth2 security scheme.
741− , _oauth2Scopes :: InsOrdHashMap Text Text
662+ , _oauth2Scopes :: HashMap Text Text
742663 } deriving (Eq, Show, Generic, Data, Typeable)
743664
744665data SecuritySchemeType
@@ -755,28 +676,12 @@ data SecurityScheme = SecurityScheme
755676 , _securitySchemeDescription :: Maybe Text
756677 } deriving (Eq, Show, Generic, Data, Typeable)
757678
758−
759−-- | merge scopes of two OAuth2 security schemes when their flows are identical.
760−-- In other case returns first security scheme
761−mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme
762−mergeSecurityScheme s1@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 scopes1)) desc)
763− s2@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow2 scopes2)) _)
764− = if flow1 == flow2 then
765− SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 (scopes1 <> scopes2))) desc
766− else
767− s1
768−mergeSecurityScheme s1 _ = s1
769−
770−newtype SecurityDefinitions
771− = SecurityDefinitions (Definitions SecurityScheme)
772− deriving (Eq, Show, Generic, Data, Typeable)
773−
774679-- | Lists the required security schemes to execute this operation.
775680-- The object can have multiple security schemes declared in it which are all required
776681-- (that is, there is a logical AND between the schemes).
777682newtype SecurityRequirement = SecurityRequirement
778− { getSecurityRequirement :: InsOrdHashMap Text [Text]
779− } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
683+ { getSecurityRequirement :: HashMap Text [Text]
684+ } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
780685
781686-- | Tag name.
782687type TagName = Text
@@ -795,8 +700,6 @@ data Tag = Tag
795700 , _tagExternalDocs :: Maybe ExternalDocs
796701 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797702
798−instance Hashable Tag
799−
800703instance IsString Tag where
801704 fromString s = Tag (fromString s) Nothing Nothing
802705
@@ -810,8 +713,6 @@ data ExternalDocs = ExternalDocs
810713 , _externalDocsUrl :: URL
811714 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812715
813−instance Hashable ExternalDocs
814−
815716-- | A simple object to allow referencing other definitions in the specification.
816717-- It can be used to reference parameters and responses that are defined at the top level for reuse.
817718newtype Reference = Reference { getReference :: Text }
@@ -825,111 +726,67 @@ data Referenced a
825726instance IsString a => IsString (Referenced a) where
826727 fromString = Inline . fromString
827728
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)
729+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)
834730
835731-- =======================================================================
836732-- Monoid instances
837733-- =======================================================================
838734
839−instance Semigroup Swagger where
840− (<>) = genericMappend
841735instance Monoid Swagger where
842736 mempty = genericMempty
843− mappend = (<>)
737+ mappend = genericMappend
844738
845−instance Semigroup Info where
846− (<>) = genericMappend
847739instance Monoid Info where
848740 mempty = genericMempty
849− mappend = (<>)
741+ mappend = genericMappend
850742
851−instance Semigroup Contact where
852− (<>) = genericMappend
853743instance Monoid Contact where
854744 mempty = genericMempty
855− mappend = (<>)
745+ mappend = genericMappend
856746
857−instance Semigroup PathItem where
858− (<>) = genericMappend
859747instance Monoid PathItem where
860748 mempty = genericMempty
861− mappend = (<>)
749+ mappend = genericMappend
862750
863−instance Semigroup Schema where
864− (<>) = genericMappend
865751instance Monoid Schema where
866752 mempty = genericMempty
867− mappend = (<>)
753+ mappend = genericMappend
868754
869−instance Semigroup (ParamSchema t) where
870− (<>) = genericMappend
871755instance Monoid (ParamSchema t) where
872756 mempty = genericMempty
873− mappend = (<>)
757+ mappend = genericMappend
874758
875−instance Semigroup Param where
876− (<>) = genericMappend
877759instance Monoid Param where
878760 mempty = genericMempty
879− mappend = (<>)
761+ mappend = genericMappend
880762
881−instance Semigroup ParamOtherSchema where
882− (<>) = genericMappend
883763instance Monoid ParamOtherSchema where
884764 mempty = genericMempty
885− mappend = (<>)
765+ mappend = genericMappend
886766
887−instance Semigroup Header where
888− (<>) = genericMappend
889767instance Monoid Header where
890768 mempty = genericMempty
891− mappend = (<>)
769+ mappend = genericMappend
892770
893−instance Semigroup Responses where
894− (<>) = genericMappend
895771instance Monoid Responses where
896772 mempty = genericMempty
897− mappend = (<>)
773+ mappend = genericMappend
898774
899−instance Semigroup Response where
900− (<>) = genericMappend
901775instance Monoid Response where
902776 mempty = genericMempty
903− mappend = (<>)
777+ mappend = genericMappend
904778
905−instance Semigroup ExternalDocs where
906− (<>) = genericMappend
907779instance Monoid ExternalDocs where
908780 mempty = genericMempty
909− mappend = (<>)
781+ mappend = genericMappend
910782
911−instance Semigroup Operation where
912− (<>) = genericMappend
913783instance Monoid Operation where
914784 mempty = genericMempty
915− mappend = (<>)
785+ mappend = genericMappend
916786
917−instance Semigroup Example where
918− (<>) = genericMappend
919787instance Monoid Example where
920788 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 = (<>)
789+ mappend = genericMappend
933790
934791-- =======================================================================
935792-- SwaggerMonoid helper instances
@@ -945,8 +802,6 @@ instance SwaggerMonoid Responses
945802instance SwaggerMonoid Response
946803instance SwaggerMonoid ExternalDocs
947804instance SwaggerMonoid Operation
948−instance SwaggerMonoid SecurityDefinitions
949−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
950805
951806instance SwaggerMonoid MimeList
952807deriving instance SwaggerMonoid URL
@@ -959,13 +814,13 @@ instance SwaggerMonoid ParamLocation where
959814 swaggerMempty = ParamQuery
960815 swaggerMappend _ y = y
961816
962−instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
963− swaggerMempty = InsOrdHashMap.empty
964− swaggerMappend = InsOrdHashMap.unionWith mappend
817+instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where
818+ swaggerMempty = HashMap.empty
819+ swaggerMappend = HashMap.unionWith mappend
965820
966821instance Monoid a => SwaggerMonoid (Referenced a) where
967822 swaggerMempty = Inline mempty
968− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
823+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
969824 swaggerMappend _ y = y
970825
971826instance SwaggerMonoid ParamAnySchema where
@@ -1059,8 +914,7 @@ instance ToJSON OAuth2Flow where
1059914 , "tokenUrl" .= tokenUrl ]
1060915
1061916instance ToJSON OAuth2Params where
1062− toJSON = sopSwaggerGenericToJSON
1063− DEFINE_TOENCODING
917+ toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")
1064918
1065919instance ToJSON SecuritySchemeType where
1066920 toJSON SecuritySchemeBasic
@@ -1073,37 +927,28 @@ instance ToJSON SecuritySchemeType where
1073927 <+> object [ "type" .= ("oauth2" :: Text) ]
1074928
1075929instance ToJSON Swagger where
1076− toJSON = sopSwaggerGenericToJSON
1077− DEFINE_TOENCODING
930+ toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")
931+ where
932+ addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)
933+ addVersion _ = error "impossible"
1078934
1079935instance ToJSON SecurityScheme where
1080− toJSON = sopSwaggerGenericToJSON
1081− DEFINE_TOENCODING
936+ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")
1082937
1083938instance ToJSON Schema where
1084− toJSON = sopSwaggerGenericToJSON
1085− DEFINE_TOENCODING
939+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")
940+ where
941+ f "items" (Array _) = True
942+ f _ _ = False
1086943
1087944instance ToJSON Header where
1088− toJSON = sopSwaggerGenericToJSON
1089− DEFINE_TOENCODING
945+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")
1090946
1091−-- | As for nullary schema for 0-arity type constructors, see
1092−-- <https://github.com/GetShopTV/swagger2/issues/167>.
1093−--
1094−-- >>> encode (SwaggerItemsArray [])
1095−-- "{\"example\":[],\"items\":{},\"maxItems\":0}"
1096−--
1097−instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
947+instance ToJSON (SwaggerItems t) where
1098948 toJSON (SwaggerItemsPrimitive fmt schema) = object
1099949 [ "collectionFormat" .= fmt
1100950 , "items" .= schema ]
1101951 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102− toJSON (SwaggerItemsArray []) = object
1103− [ "items" .= object []
1104− , "maxItems" .= (0 :: Int)
1105− , "example" .= Array mempty
1106− ]
1107952 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
1108953
1109954instance ToJSON Host where
@@ -1116,39 +961,31 @@ instance ToJSON MimeList where
1116961 toJSON (MimeList xs) = toJSON (map show xs)
1117962
1118963instance ToJSON Param where
1119− toJSON = sopSwaggerGenericToJSON
1120− DEFINE_TOENCODING
964+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")
1121965
1122966instance ToJSON ParamAnySchema where
1123967 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]
1124968 toJSON (ParamOther s) = toJSON s
1125969
1126970instance ToJSON ParamOtherSchema where
1127− toJSON = sopSwaggerGenericToJSON
1128− DEFINE_TOENCODING
971+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
1129972
1130973instance ToJSON Responses where
1131− toJSON = sopSwaggerGenericToJSON
1132− DEFINE_TOENCODING
974+ toJSON (Responses def rs) = omitEmpties $
975+ toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]
1133976
1134977instance ToJSON Response where
1135− toJSON = sopSwaggerGenericToJSON
1136− DEFINE_TOENCODING
978+ toJSON = omitEmpties . genericToJSON (jsonPrefix "response")
1137979
1138980instance ToJSON Operation where
1139− toJSON = sopSwaggerGenericToJSON
1140− DEFINE_TOENCODING
981+ toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")
1141982
1142983instance ToJSON PathItem where
1143− toJSON = sopSwaggerGenericToJSON
1144− DEFINE_TOENCODING
984+ toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")
1145985
1146986instance ToJSON Example where
1147987 toJSON = toJSON . Map.mapKeys show . getExample
1148988
1149−instance ToJSON SecurityDefinitions where
1150− toJSON (SecurityDefinitions sd) = toJSON sd
1151−
1152989instance ToJSON Reference where
1153990 toJSON (Reference ref) = object [ "$ref" .= ref ]
1154991
@@ -1177,14 +1014,11 @@ instance ToJSON (CollectionFormat t) where
11771014 toJSON CollectionPipes = "pipes"
11781015 toJSON CollectionMulti = "multi"
11791016
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
1017+instance ToJSON (ParamSchema t) where
1018+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")
1019+ where
1020+ f "items" (Array _) = True
1021+ f _ _ = False
11881022
11891023-- =======================================================================
11901024-- Manual FromJSON instances
@@ -1204,7 +1038,7 @@ instance FromJSON OAuth2Flow where
12041038 parseJSON _ = empty
12051039
12061040instance FromJSON OAuth2Params where
1207− parseJSON = sopSwaggerGenericParseJSON
1041+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")
12081042
12091043instance FromJSON SecuritySchemeType where
12101044 parseJSON js@(Object o) = do
@@ -1217,48 +1051,39 @@ instance FromJSON SecuritySchemeType where
12171051 parseJSON _ = empty
12181052
12191053instance FromJSON Swagger where
1220− parseJSON = sopSwaggerGenericParseJSON
1054+ parseJSON js@(Object o) = do
1055+ (version :: Text) <- o .: "swagger"
1056+ when (version /= "2.0") empty
1057+ (genericParseJSON (jsonPrefix "swagger")
1058+ `withDefaults` [ "consumes" .= (mempty :: MimeList)
1059+ , "produces" .= (mempty :: MimeList)
1060+ , "security" .= ([] :: [SecurityRequirement])
1061+ , "tags" .= ([] :: [Tag])
1062+ , "definitions" .= (mempty :: Definitions Schema)
1063+ , "parameters" .= (mempty :: Definitions Param)
1064+ , "responses" .= (mempty :: Definitions Response)
1065+ , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)
1066+ ] ) js
1067+ parseJSON _ = empty
12211068
12221069instance FromJSON SecurityScheme where
1223− parseJSON = sopSwaggerGenericParseJSON
1070+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")
12241071
12251072instance 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
1073+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")
1074+ `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)
1075+ , "required" .= ([] :: [ParamName]) ]
12331076
12341077instance FromJSON Header where
1235− parseJSON = sopSwaggerGenericParseJSON
1078+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")
12361079
1237−instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where
1080+instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where
12381081 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive
12391082 <$> o .:? "collectionFormat"
12401083 <*> (o .: "items" >>= parseJSON)
12411084
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
1085+instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where
1086+ parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
12621087 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
12631088 parseJSON _ = empty
12641089
@@ -1275,7 +1100,7 @@ instance FromJSON MimeList where
12751100 parseJSON js = (MimeList . map fromString) <$> parseJSON js
12761101
12771102instance FromJSON Param where
1278− parseJSON = sopSwaggerGenericParseJSON
1103+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")
12791104
12801105instance FromJSON ParamAnySchema where
12811106 parseJSON js@(Object o) = do
@@ -1288,12 +1113,12 @@ instance FromJSON ParamAnySchema where
12881113 parseJSON _ = empty
12891114
12901115instance FromJSON ParamOtherSchema where
1291− parseJSON = sopSwaggerGenericParseJSON
1116+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")
12921117
12931118instance FromJSON Responses where
12941119 parseJSON (Object o) = Responses
12951120 <$> o .:? "default"
1296− <*> (parseJSON (Object (HashMap.delete "default" o)))
1121+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)
12971122 parseJSON _ = empty
12981123
12991124instance FromJSON Example where
@@ -1302,16 +1127,18 @@ instance FromJSON Example where
13021127 pure $ Example (Map.mapKeys fromString m)
13031128
13041129instance FromJSON Response where
1305− parseJSON = sopSwaggerGenericParseJSON
1130+ parseJSON = genericParseJSON (jsonPrefix "response")
1131+ `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]
13061132
13071133instance FromJSON Operation where
1308− parseJSON = sopSwaggerGenericParseJSON
1134+ parseJSON = genericParseJSON (jsonPrefix "operation")
1135+ `withDefaults` [ "security" .= ([] :: [SecurityRequirement])
1136+ , "tags" .= ([] :: [Tag])
1137+ , "parameters" .= ([] :: [Referenced Param]) ]
13091138
13101139instance FromJSON PathItem where
1311− parseJSON = sopSwaggerGenericParseJSON
1312−
1313−instance FromJSON SecurityDefinitions where
1314− parseJSON js = SecurityDefinitions <$> parseJSON js
1140+ parseJSON = genericParseJSON (jsonPrefix "pathItem")
1141+ `withDefaults` [ "parameters" .= ([] :: [Param]) ]
13151142
13161143instance FromJSON Reference where
13171144 parseJSON (Object o) = Reference <$> o .: "$ref"
@@ -1337,91 +1164,26 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#
13371164instance FromJSON Xml where
13381165 parseJSON = genericParseJSON (jsonPrefix "xml")
13391166
1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where
1167+instance FromJSON (SwaggerType Schema) where
13411168 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]
13421169
1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where
1170+instance FromJSON (SwaggerType ParamOtherSchema) where
13441171 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]
13451172
1346−instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where
1173+instance OVERLAPPABLE_ FromJSON (SwaggerType t) where
13471174 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]
13481175
1349−instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where
1176+instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where
13501177 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]
13511178
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
1179+instance FromJSON (CollectionFormat ParamOtherSchema) where
13571180 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]
13581181
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
1182+-- NOTE: The constraints @FromJSON (SwaggerType t)@ and
1183+-- @FromJSON (SwaggerItems t)@ are necessary here!
1184+-- Without the constraint the general instance will be used
1185+-- that only accepts common types (i.e. NOT object, null or file)
1186+-- and primitive array items.
1187+instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where
1188+ parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")
1189+
src/Data/Swagger/Internal/AesonUtils.hsdeleted−346
@@ -1,346 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# LANGUAGE ExplicitForAll #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−#if __GLASGOW_HASKELL__ >= 800
9−{-# LANGUAGE UndecidableSuperClasses #-}
10−#endif
11−module Data.Swagger.Internal.AesonUtils (
12− -- * Generic functions
13− AesonDefaultValue(..),
14− sopSwaggerGenericToJSON,
15−#if MIN_VERSION_aeson(0,10,0)
16− sopSwaggerGenericToEncoding,
17−#endif
18− sopSwaggerGenericToJSONWithOpts,
19− sopSwaggerGenericParseJSON,
20− -- * Options
21− HasSwaggerAesonOptions(..),
22− SwaggerAesonOptions,
23− mkSwaggerAesonOptions,
24− saoPrefix,
25− saoAdditionalPairs,
26− saoSubObject,
27− ) where
28−
29−import Prelude ()
30−import Prelude.Compat
31−
32−import Control.Applicative ((<|>))
33−import Control.Lens (makeLenses, (^.))
34−import Control.Monad (unless)
35−import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)
36−import Data.Aeson.Types (Parser, Pair)
37−import Data.Char (toLower, isUpper)
38−import Data.Foldable (traverse_)
39−import Data.Text (Text)
40−
41−import Generics.SOP
42−
43−import qualified Data.Text as T
44−import qualified Data.HashMap.Strict as HM
45−import qualified Data.Set as Set
46−import qualified Data.HashMap.Strict.InsOrd as InsOrd
47−import qualified Data.HashSet.InsOrd as InsOrdHS
48−
49−#if MIN_VERSION_aeson(0,10,0)
50−import Data.Aeson (Encoding, pairs, (.=), Series)
51−#endif
52−
53−-------------------------------------------------------------------------------
54−-- SwaggerAesonOptions
55−-------------------------------------------------------------------------------
56−
57−data SwaggerAesonOptions = SwaggerAesonOptions
58− { _saoPrefix :: String
59− , _saoAdditionalPairs :: [(Text, Value)]
60− , _saoSubObject :: Maybe String
61− }
62−
63−mkSwaggerAesonOptions
64− :: String -- ^ prefix
65− -> SwaggerAesonOptions
66−mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
67−
68−makeLenses ''SwaggerAesonOptions
69−
70−class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions
72−
73− -- So far we use only default definitions
74− aesonDefaults :: Proxy a -> POP Maybe (Code a)
75− aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
76−
77−-------------------------------------------------------------------------------
78−-- Generics
79−-------------------------------------------------------------------------------
80−
81−class AesonDefaultValue a where
82− defaultValue :: Maybe a
83− defaultValue = Nothing
84−
85−instance AesonDefaultValue Text where defaultValue = Nothing
86−instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
87−instance AesonDefaultValue [a] where defaultValue = Just []
88−instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
89−instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty
90−instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
91−
92−-------------------------------------------------------------------------------
93−-- ToJSON
94−-------------------------------------------------------------------------------
95−
96−-- | Generic serialisation for swagger records.
97−--
98−-- Features
99−--
100−-- * omits nulls, empty objects and empty arrays (configurable)
101−-- * possible to add fields
102−-- * possible to merge sub-object
103−sopSwaggerGenericToJSON
104− :: forall a xs.
105− ( HasDatatypeInfo a
106− , HasSwaggerAesonOptions a
107− , All2 ToJSON (Code a)
108− , All2 Eq (Code a)
109− , Code a ~ '[xs]
110− )
111− => a
112− -> Value
113−sopSwaggerGenericToJSON x =
114− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
115− in object (opts ^. saoAdditionalPairs ++ ps)
116− where
117− proxy = Proxy :: Proxy a
118− opts = swaggerAesonOptions proxy
119−
120−-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)
121−--
122−-- Also uses default `aesonDefaults`
123−sopSwaggerGenericToJSONWithOpts
124− :: forall a xs.
125− ( Generic a
126− , All2 AesonDefaultValue (Code a)
127− , HasDatatypeInfo a
128− , All2 ToJSON (Code a)
129− , All2 Eq (Code a)
130− , Code a ~ '[xs]
131− )
132− => SwaggerAesonOptions
133− -> a
134− -> Value
135−sopSwaggerGenericToJSONWithOpts opts x =
136− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs
137− in object (opts ^. saoAdditionalPairs ++ ps)
138− where
139− proxy = Proxy :: Proxy a
140− defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
141−
142−sopSwaggerGenericToJSON'
143− :: (All2 ToJSON '[xs], All2 Eq '[xs])
144− => SwaggerAesonOptions
145− -> SOP I '[xs]
146− -> DatatypeInfo '[xs]
147− -> POP Maybe '[xs]
148− -> [Pair]
149−#if MIN_VERSION_generics_sop(0,5,0)
150−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
151−#else
152−sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
153−#endif
154− sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
155−sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
156−
157−sopSwaggerGenericToJSON''
158− :: (All ToJSON xs, All Eq xs)
159− => SwaggerAesonOptions
160− -> NP I xs
161− -> NP FieldInfo xs
162− -> NP Maybe xs
163− -> [Pair]
164−sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go
165− where
166− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]
167− go Nil Nil Nil = []
168− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
169− | Just name' == sub = case json of
170− Object m -> HM.toList m ++ rest
171− Null -> rest
172− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json
173− -- If default value: omit it.
174− | Just x == def =
175− rest
176− | otherwise =
177− (T.pack name', json) : rest
178− where
179− json = toJSON x
180− name' = fieldNameModifier name
181− rest = go xs names defs
182−#if __GLASGOW_HASKELL__ < 800
183− go _ _ _ = error "not empty"
184−#endif
185−
186− fieldNameModifier = modifier . drop 1
187− modifier = lowerFirstUppers . drop (length prefix)
188− lowerFirstUppers s = map toLower x ++ y
189− where (x, y) = span isUpper s
190−
191−-------------------------------------------------------------------------------
192−-- FromJSON
193−-------------------------------------------------------------------------------
194−
195−sopSwaggerGenericParseJSON
196− :: forall a xs.
197− ( HasDatatypeInfo a
198− , HasSwaggerAesonOptions a
199− , All2 FromJSON (Code a)
200− , All2 Eq (Code a)
201− , Code a ~ '[xs]
202− )
203− => Value
204− -> Parser a
205−sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
206− let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)
207− in do
208− traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)
209− to <$> ps
210− where
211− proxy = Proxy :: Proxy a
212− opts = swaggerAesonOptions proxy
213−
214− parseAdditionalField :: Object -> (Text, Value) -> Parser ()
215− parseAdditionalField obj (k, v) = do
216− v' <- obj .: k
217− unless (v == v') $ fail $
218− "Additonal field don't match for key " ++ T.unpack k
219− ++ ": " ++ show v
220− ++ " /= " ++ show v'
221−
222−sopSwaggerGenericParseJSON'
223− :: (All2 FromJSON '[xs], All2 Eq '[xs])
224− => SwaggerAesonOptions
225− -> Object
226− -> DatatypeInfo '[xs]
227− -> POP Maybe '[xs]
228− -> Parser (SOP I '[xs])
229−#if MIN_VERSION_generics_sop(0,5,0)
230−sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
231−#else
232−sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
233−#endif
234− SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
235−sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
236−
237−sopSwaggerGenericParseJSON''
238− :: (All FromJSON xs, All Eq xs)
239− => SwaggerAesonOptions
240− -> Object
241− -> NP FieldInfo xs
242− -> NP Maybe xs
243− -> Parser (NP I xs)
244−sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
245− where
246− go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)
247− go Nil Nil = pure Nil
248− go (FieldInfo name :* names) (def :* defs)
249− | Just name' == sub =
250− -- Note: we might strip fields of outer structure.
251− cons <$> (withDef $ parseJSON $ Object obj) <*> rest
252− | otherwise = case def of
253− Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest
254− Nothing -> cons <$> obj .: T.pack name' <*> rest
255− where
256− cons h t = I h :* t
257− name' = fieldNameModifier name
258− rest = go names defs
259−
260− withDef = case def of
261− Just def' -> (<|> pure def')
262− Nothing -> id
263−#if __GLASGOW_HASKELL__ < 800
264− go _ _ = error "not empty"
265−#endif
266−
267− fieldNameModifier = modifier . drop 1
268− modifier = lowerFirstUppers . drop (length prefix)
269− lowerFirstUppers s = map toLower x ++ y
270− where (x, y) = span isUpper s
271−
272−-------------------------------------------------------------------------------
273−-- ToEncoding
274−-------------------------------------------------------------------------------
275−
276−#if MIN_VERSION_aeson(0,10,0)
277−
278−sopSwaggerGenericToEncoding
279− :: forall a xs.
280− ( HasDatatypeInfo a
281− , HasSwaggerAesonOptions a
282− , All2 ToJSON (Code a)
283− , All2 Eq (Code a)
284− , Code a ~ '[xs]
285− )
286− => a
287− -> Encoding
288−sopSwaggerGenericToEncoding x =
289− let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)
290− in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)
291− where
292− proxy = Proxy :: Proxy a
293− opts = swaggerAesonOptions proxy
294−
295−pairsToSeries :: [Pair] -> Series
296−pairsToSeries = foldMap (\(k, v) -> (k .= v))
297−
298−sopSwaggerGenericToEncoding'
299− :: (All2 ToJSON '[xs], All2 Eq '[xs])
300− => SwaggerAesonOptions
301− -> SOP I '[xs]
302− -> DatatypeInfo '[xs]
303− -> POP Maybe '[xs]
304− -> Series
305−#if MIN_VERSION_generics_sop(0,5,0)
306−sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =
307−#else
308−sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
309−#endif
310− sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
311−sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
312−
313−sopSwaggerGenericToEncoding''
314− :: (All ToJSON xs, All Eq xs)
315− => SwaggerAesonOptions
316− -> NP I xs
317− -> NP FieldInfo xs
318− -> NP Maybe xs
319− -> Series
320−sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go
321− where
322− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series
323− go Nil Nil Nil = mempty
324− go (I x :* xs) (FieldInfo name :* names) (def :* defs)
325− | Just name' == sub = case toJSON x of
326− Object m -> pairsToSeries (HM.toList m) <> rest
327− Null -> rest
328− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)
329− -- If default value: omit it.
330− | Just x == def =
331− rest
332− | otherwise =
333− (T.pack name' .= x) <> rest
334− where
335− name' = fieldNameModifier name
336− rest = go xs names defs
337−#if __GLASGOW_HASKELL__ < 800
338− go _ _ _ = error "not empty"
339−#endif
340−
341− fieldNameModifier = modifier . drop 1
342− modifier = lowerFirstUppers . drop (length prefix)
343− lowerFirstUppers s = map toLower x ++ y
344− where (x, y) = span isUpper s
345−
346−#endif
src/Data/Swagger/Internal/ParamSchema.hs+26−95
@@ -1,5 +1,4 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
32{-# LANGUAGE DefaultSignatures #-}
43{-# LANGUAGE FlexibleContexts #-}
54{-# LANGUAGE FlexibleInstances #-}
@@ -8,21 +7,13 @@
87{-# LANGUAGE PackageImports #-}
98{-# LANGUAGE PolyKinds #-}
109{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TypeFamilies #-}
1210{-# LANGUAGE TypeOperators #-}
1311{-# 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
2112#include "overlapping-compat.h"
2213module Data.Swagger.Internal.ParamSchema where
2314
2415import Control.Lens
25−import Data.Aeson (ToJSON (..))
16+import Data.Aeson
2617import Data.Proxy
2718import GHC.Generics
2819
@@ -31,7 +22,6 @@ import "unordered-containers" Data.HashSet (HashSet)
3122import Data.Monoid
3223import Data.Set (Set)
3324import Data.Scientific
34−import Data.Fixed (HasResolution(..), Fixed, Pico)
3525import qualified Data.Text as T
3626import qualified Data.Text.Lazy as TL
3727import Data.Time
@@ -39,40 +29,29 @@ import qualified Data.Vector as V
3929import qualified Data.Vector.Primitive as VP
4030import qualified Data.Vector.Storable as VS
4131import qualified Data.Vector.Unboxed as VU
42−import Data.Version (Version)
43−import Numeric.Natural.Compat (Natural)
4432import Data.Word
45−import Data.UUID.Types (UUID)
46−import Web.Cookie (SetCookie)
4733
4834import Data.Swagger.Internal
4935import Data.Swagger.Lens
5036import Data.Swagger.SchemaOptions
5137
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−
5938-- | Default schema for binary data (any sequence of octets).
6039binaryParamSchema :: ParamSchema t
6140binaryParamSchema = mempty
62− & type_ ?~ SwaggerString
41+ & type_ .~ SwaggerString
6342 & format ?~ "binary"
6443
6544-- | Default schema for binary data (base64 encoded).
6645byteParamSchema :: ParamSchema t
6746byteParamSchema = mempty
68− & type_ ?~ SwaggerString
47+ & type_ .~ SwaggerString
6948 & format ?~ "byte"
7049
7150-- | Default schema for password string.
7251-- @"password"@ format is used to hint UIs the input needs to be obscured.
7352passwordParamSchema :: ParamSchema t
7453passwordParamSchema = mempty
75− & type_ ?~ SwaggerString
54+ & type_ .~ SwaggerString
7655 & format ?~ "password"
7756
7857-- | Convert a type into a plain @'ParamSchema'@.
@@ -87,9 +66,9 @@ passwordParamSchema = mempty
8766-- data Direction = Up | Down
8867--
8968-- instance ToParamSchema Direction where
90−-- toParamSchema _ = mempty
91−-- & type_ ?~ SwaggerString
92−-- & enum_ ?~ [ \"Up\", \"Down\" ]
69+-- toParamSchema = mempty
70+-- & type_ .~ SwaggerString
71+-- & enum_ .~ [ \"Up\", \"Down\" ]
9372-- @
9473--
9574-- Instead of manually writing your @'ToParamSchema'@ instance you can
@@ -115,24 +94,18 @@ class ToParamSchema a where
11594 --
11695 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
11796 -- "{\"type\":\"integer\"}"
118− toParamSchema :: Proxy a -> ParamSchema t
119− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
97+ toParamSchema :: proxy a -> ParamSchema t
98+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
12099 toParamSchema = genericToParamSchema defaultSchemaOptions
121100
122101instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ ?~ SwaggerString
102+ toParamSchema _ = mempty & type_ .~ SwaggerString
124103
125104instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
105+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean
127106
128107instance 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
108+ toParamSchema _ = mempty & type_ .~ SwaggerInteger
136109
137110instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
138111instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -154,51 +127,40 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
154127--
155128-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156129-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
130+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
158131toParamSchemaBoundedIntegral _ = mempty
159− & type_ ?~ SwaggerInteger
132+ & type_ .~ SwaggerInteger
160133 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161134 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162135
163136instance ToParamSchema Char where
164137 toParamSchema _ = mempty
165− & type_ ?~ SwaggerString
138+ & type_ .~ SwaggerString
166139 & maxLength ?~ 1
167140 & minLength ?~ 1
168141
169142instance 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))
143+ toParamSchema _ = mempty & type_ .~ SwaggerNumber
176144
177145instance ToParamSchema Double where
178146 toParamSchema _ = mempty
179− & type_ ?~ SwaggerNumber
147+ & type_ .~ SwaggerNumber
180148 & format ?~ "double"
181149
182150instance ToParamSchema Float where
183151 toParamSchema _ = mempty
184− & type_ ?~ SwaggerNumber
152+ & type_ .~ SwaggerNumber
185153 & format ?~ "float"
186154
187155timeParamSchema :: String -> ParamSchema t
188156timeParamSchema fmt = mempty
189− & type_ ?~ SwaggerString
157+ & type_ .~ SwaggerString
190158 & format ?~ T.pack fmt
191159
192160-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
193161instance ToParamSchema Day where
194162 toParamSchema _ = timeParamSchema "date"
195163
196−-- |
197−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198−-- Just "hh:MM:ss"
199−instance ToParamSchema TimeOfDay where
200− toParamSchema _ = timeParamSchema "hh:MM:ss"
201−
202164-- |
203165-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
204166-- Just "yyyy-mm-ddThh:MM:ss"
@@ -218,7 +180,7 @@ instance ToParamSchema UTCTime where
218180 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
219181
220182instance ToParamSchema NominalDiffTime where
221− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
183+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
222184
223185instance ToParamSchema T.Text where
224186 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -226,28 +188,6 @@ instance ToParamSchema T.Text where
226188instance ToParamSchema TL.Text where
227189 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
228190
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−
251191instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
252192instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)
253193instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
@@ -256,11 +196,9 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
256196instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
257197instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
258198
259−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
260−
261199instance ToParamSchema a => ToParamSchema [a] where
262200 toParamSchema _ = mempty
263− & type_ ?~ SwaggerArray
201+ & type_ .~ SwaggerArray
264202 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
265203
266204instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -280,25 +218,20 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
280218-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
281219instance ToParamSchema () where
282220 toParamSchema _ = mempty
283− & type_ ?~ SwaggerString
221+ & type_ .~ SwaggerString
284222 & enum_ ?~ ["_"]
285223
286−instance ToParamSchema UUID where
287− toParamSchema _ = mempty
288− & type_ ?~ SwaggerString
289− & format ?~ "uuid"
290−
291224-- | A configurable generic @'ParamSchema'@ creator.
292225--
293226-- >>> :set -XDeriveGeneric
294227-- >>> data Color = Red | Blue deriving Generic
295228-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
296229-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
230+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
298231genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
299232
300233class GToParamSchema (f :: * -> *) where
301− gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
234+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
302235
303236instance GToParamSchema f => GToParamSchema (D1 d f) where
304237 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -316,14 +249,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
316249 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
317250
318251class GEnumParamSchema (f :: * -> *) where
319− genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
252+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
320253
321254instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
322255 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
323256
324257instance Constructor c => GEnumParamSchema (C1 c U1) where
325258 genumParamSchema opts _ s = s
326− & type_ ?~ SwaggerString
259+ & type_ .~ SwaggerString
327260 & enum_ %~ addEnumValue tag
328261 where
329262 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -333,5 +266,3 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
333266
334267data Proxy3 a b c = Proxy3
335268
336−-- $setup
337−-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hs+105−280
@@ -1,10 +1,8 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE DefaultSignatures #-}
43{-# LANGUAGE FlexibleContexts #-}
54{-# LANGUAGE FlexibleInstances #-}
65{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE DataKinds #-}
86{-# LANGUAGE OverloadedLists #-}
97{-# LANGUAGE OverloadedStrings #-}
108{-# LANGUAGE PackageImports #-}
@@ -14,13 +12,6 @@
1412{-# LANGUAGE TypeFamilies #-}
1513{-# LANGUAGE TypeOperators #-}
1614{-# 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
2415#include "overlapping-compat.h"
2516module Data.Swagger.Internal.Schema where
2617
@@ -30,25 +21,24 @@ import Prelude.Compat
3021import Control.Lens
3122import Data.Data.Lens (template)
3223
24+import Control.Applicative
3325import Control.Monad
3426import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
27+import Data.Aeson
3628import Data.Char
3729import Data.Data (Data)
3830import Data.Foldable (traverse_)
31+import Data.Function (on)
3932import Data.HashMap.Strict (HashMap)
4033import qualified Data.HashMap.Strict as HashMap
4134import "unordered-containers" Data.HashSet (HashSet)
4235import qualified "unordered-containers" Data.HashSet as HashSet
43−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4436import Data.Int
4537import Data.IntSet (IntSet)
4638import Data.IntMap (IntMap)
47−import Data.List.NonEmpty.Compat (NonEmpty)
4839import Data.Map (Map)
4940import Data.Proxy
5041import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
5242import Data.Set (Set)
5343import qualified Data.Text as T
5444import qualified Data.Text.Lazy as TL
@@ -57,25 +47,17 @@ import qualified Data.Vector as V
5747import qualified Data.Vector.Primitive as VP
5848import qualified Data.Vector.Storable as VS
5949import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
6250import Data.Word
6351import GHC.Generics
64−import qualified Data.UUID.Types as UUID
6552
6653import Data.Swagger.Declare
6754import Data.Swagger.Internal
6855import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
6956import Data.Swagger.Lens hiding (name, schema)
70−import qualified Data.Swagger.Lens as Swagger
7157import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
7358
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(..))
59+#ifdef __DOCTEST__
60+import Data.Swagger.Lens (name, schema)
7961#endif
8062
8163unnamed :: Schema -> NamedSchema
@@ -102,21 +84,19 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
10284-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists
10385--
10486-- import Control.Lens
105−-- import Data.Proxy
106−-- import Data.Swagger
10787--
10888-- data Coord = Coord { x :: Double, y :: Double }
10989--
11090-- 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\" ]
91+-- declareNamedSchema = pure (Just \"Coord\", schema)
92+-- where
93+-- schema = mempty
94+-- & type_ .~ SwaggerObject
95+-- & properties .~
96+-- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))
97+-- , (\"y\", toSchemaRef (Proxy :: Proxy Double))
98+-- ]
99+-- & required .~ [ \"x\", \"y\" ]
120100-- @
121101--
122102-- Instead of manually writing your @'ToSchema'@ instance you can
@@ -142,17 +122,12 @@ class ToSchema a where
142122 -- together with all used definitions.
143123 -- Note that the schema itself is included in definitions
144124 -- 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
125+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
126+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
148127 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149128
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154129-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
130+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
156131declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157132
158133-- | Convert a type into an optionally named schema.
@@ -165,8 +140,8 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
165140-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
166141-- Just "Day"
167142-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168−-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
143+-- "{\"format\":\"date\",\"type\":\"string\"}"
144+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
170145toNamedSchema = undeclare . declareNamedSchema
171146
172147-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -176,7 +151,7 @@ toNamedSchema = undeclare . declareNamedSchema
176151--
177152-- >>> schemaName (Proxy :: Proxy UTCTime)
178153-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
154+schemaName :: ToSchema a => proxy a -> Maybe T.Text
180155schemaName = _namedSchemaName . toNamedSchema
181156
182157-- | Convert a type into a schema.
@@ -186,7 +161,7 @@ schemaName = _namedSchemaName . toNamedSchema
186161--
187162-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188163-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
164+toSchema :: ToSchema a => proxy a -> Schema
190165toSchema = _namedSchemaSchema . toNamedSchema
191166
192167-- | Convert a type into a referenced schema if possible.
@@ -197,7 +172,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
197172--
198173-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199174-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
175+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
201176toSchemaRef = undeclare . declareSchemaRef
202177
203178-- | Convert a type into a referenced schema if possible
@@ -207,7 +182,7 @@ toSchemaRef = undeclare . declareSchemaRef
207182-- Schema definitions are typically declared for every referenced schema.
208183-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209184-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
185+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
211186declareSchemaRef proxy = do
212187 case toNamedSchema proxy of
213188 NamedSchema (Just name) schema -> do
@@ -219,7 +194,7 @@ declareSchemaRef proxy = do
219194 -- have already declared it.
220195 -- If we have, we don't need to declare anything for
221196 -- this schema this time and thus simply return the reference.
222− known <- looks (InsOrdHashMap.member name)
197+ known <- looks (HashMap.member name)
223198 when (not known) $ do
224199 declare [(name, schema)]
225200 void $ declareNamedSchema proxy
@@ -238,7 +213,7 @@ inlineSchemasWhen p defs = template %~ deref
238213 where
239214 deref r@(Ref (Reference name))
240215 | p name =
241− case InsOrdHashMap.lookup name defs of
216+ case HashMap.lookup name defs of
242217 Just schema -> Inline (inlineSchemasWhen p defs schema)
243218 Nothing -> r
244219 | otherwise = r
@@ -265,11 +240,11 @@ inlineAllSchemas = inlineSchemasWhen (const True)
265240-- | Convert a type into a schema without references.
266241--
267242-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
243+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
269244--
270245-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271246-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
247+toInlinedSchema :: ToSchema a => proxy a -> Schema
273248toInlinedSchema proxy = inlineAllSchemas defs schema
274249 where
275250 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -280,7 +255,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
280255inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
281256 where
282257 nonRecursive name =
283− case InsOrdHashMap.lookup name defs of
258+ case HashMap.lookup name defs of
284259 Just schema -> name `notElem` execDeclare (usedNames schema) mempty
285260 Nothing -> False
286261
@@ -292,26 +267,26 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
292267 seen <- looks (name `elem`)
293268 when (not seen) $ do
294269 declare [name]
295− traverse_ usedNames (InsOrdHashMap.lookup name defs)
270+ traverse_ usedNames (HashMap.lookup name defs)
296271 Inline subschema -> usedNames subschema
297272
298273-- | Default schema for binary data (any sequence of octets).
299274binarySchema :: Schema
300275binarySchema = mempty
301− & type_ ?~ SwaggerString
276+ & type_ .~ SwaggerString
302277 & format ?~ "binary"
303278
304279-- | Default schema for binary data (base64 encoded).
305280byteSchema :: Schema
306281byteSchema = mempty
307− & type_ ?~ SwaggerString
282+ & type_ .~ SwaggerString
308283 & format ?~ "byte"
309284
310285-- | Default schema for password string.
311286-- @"password"@ format is used to hint UIs the input needs to be obscured.
312287passwordSchema :: Schema
313288passwordSchema = mempty
314− & type_ ?~ SwaggerString
289+ & type_ .~ SwaggerString
315290 & format ?~ "password"
316291
317292-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -329,7 +304,7 @@ passwordSchema = mempty
329304-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
330305-- >>> instance ToJSON Person
331306-- >>> encode $ sketchSchema (Person "Jack" 25)
332−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
307+-- "{\"example\":{\"age\":25,\"name\":\"Jack\"},\"required\":[\"age\",\"name\"],\"type\":\"object\",\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}}}"
333308sketchSchema :: ToJSON a => a -> Schema
334309sketchSchema = sketch . toJSON
335310 where
@@ -337,12 +312,12 @@ sketchSchema = sketch . toJSON
337312 sketch js@(Bool _) = go js
338313 sketch js = go js & example ?~ js
339314
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
315+ go Null = mempty & type_ .~ SwaggerNull
316+ go js@(Bool _) = mempty & type_ .~ SwaggerBoolean
317+ go js@(String s) = mempty & type_ .~ SwaggerString
318+ go js@(Number n) = mempty & type_ .~ SwaggerNumber
319+ go js@(Array xs) = mempty
320+ & type_ .~ SwaggerArray
346321 & items ?~ case ischema of
347322 Just s -> SwaggerItemsObject (Inline s)
348323 _ -> SwaggerItemsArray (map Inline ys)
@@ -351,12 +326,12 @@ sketchSchema = sketch . toJSON
351326 allSame = and ((zipWith (==)) ys (tail ys))
352327
353328 ischema = case ys of
354− (z:_) | allSame -> Just z
355− _ -> Nothing
356− go (Object o) = mempty
357− & type_ ?~ SwaggerObject
329+ (z:zs) | allSame -> Just z
330+ _ -> Nothing
331+ go js@(Object o) = mempty
332+ & type_ .~ SwaggerObject
358333 & required .~ HashMap.keys o
359− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
334+ & properties .~ fmap (Inline . go) o
360335
361336-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
362337-- Produced schema uses as much constraints as possible.
@@ -373,28 +348,28 @@ sketchSchema = sketch . toJSON
373348-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
374349-- >>> instance ToJSON Person
375350-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
376−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}"
351+-- "{\"minProperties\":2,\"required\":[\"age\",\"name\"],\"maxProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}}}"
377352sketchStrictSchema :: ToJSON a => a -> Schema
378353sketchStrictSchema = go . toJSON
379354 where
380− go Null = mempty & type_ ?~ SwaggerNull
355+ go Null = mempty & type_ .~ SwaggerNull
381356 go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
357+ & type_ .~ SwaggerBoolean
383358 & enum_ ?~ [js]
384359 go js@(String s) = mempty
385− & type_ ?~ SwaggerString
360+ & type_ .~ SwaggerString
386361 & maxLength ?~ fromIntegral (T.length s)
387362 & minLength ?~ fromIntegral (T.length s)
388363 & pattern ?~ s
389364 & enum_ ?~ [js]
390365 go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
366+ & type_ .~ SwaggerNumber
392367 & maximum_ ?~ n
393368 & minimum_ ?~ n
394369 & multipleOf ?~ n
395370 & enum_ ?~ [js]
396371 go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
372+ & type_ .~ SwaggerArray
398373 & maxItems ?~ fromIntegral sz
399374 & minItems ?~ fromIntegral sz
400375 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -404,9 +379,9 @@ sketchStrictSchema = go . toJSON
404379 sz = length xs
405380 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406381 go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
382+ & type_ .~ SwaggerObject
408383 & required .~ names
409− & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
384+ & properties .~ fmap (Inline . go) o
410385 & maxProperties ?~ fromIntegral (length names)
411386 & minProperties ?~ fromIntegral (length names)
412387 & enum_ ?~ [js]
@@ -414,19 +389,18 @@ sketchStrictSchema = go . toJSON
414389 names = HashMap.keys o
415390
416391class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
392+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418393
419394instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420395 declareNamedSchema _ = do
421396 ref <- declareSchemaRef (Proxy :: Proxy a)
422397 return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
398+ & type_ .~ SwaggerArray
424399 & items ?~ SwaggerItemsObject ref
425400
426401instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427402instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428403instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430404instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431405instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432406instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -438,16 +412,11 @@ instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema
438412instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema
439413instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema
440414
441−instance ToSchema Char where
442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
443− & mapped.Swagger.schema.example ?~ toJSON '?'
444−
415+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema
445416instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema
446417instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447418instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448419
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451420instance ToSchema a => ToSchema (Maybe a) where
452421 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453422
@@ -456,11 +425,6 @@ instance (ToSchema a, ToSchema b) => ToSchema (Either a b)
456425instance ToSchema () where
457426 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)
458427
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−
464428instance (ToSchema a, ToSchema b) => ToSchema (a, b)
465429instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
466430instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
@@ -470,81 +434,46 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
470434
471435timeSchema :: T.Text -> Schema
472436timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
437+ & type_ .~ SwaggerString
474438 & format ?~ fmt
475439
476440-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
477441instance ToSchema Day where
478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
479− & example ?~ toJSON (fromGregorian 2016 7 22)
442+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")
480443
481444-- |
482445-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
483446-- Just "yyyy-mm-ddThh:MM:ss"
484447instance 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))
448+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")
487449
488450-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
489451instance ToSchema ZonedTime where
490452 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
491− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492453
493454instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
455+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
495456
496457-- |
497458-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
498459-- Just "yyyy-mm-ddThh:MM:ssZ"
499460instance ToSchema UTCTime where
500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)
461+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")
502462
503463instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504464instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505465
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−
520466instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))
521467
522468-- | NOTE: This schema does not account for the uniqueness of keys.
523469instance ToSchema a => ToSchema (IntMap a) where
524470 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])
525471
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−
543472instance ToSchema a => ToSchema (Map String a) where
544473 declareNamedSchema _ = do
545− schema <- declareSchemaRef (Proxy :: Proxy a)
474+ schema <- declareSchema (Proxy :: Proxy a)
546475 return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
476+ & type_ .~ SwaggerObject
548477 & additionalProperties ?~ schema
549478
550479instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -554,14 +483,6 @@ instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ =
554483instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
555484instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
556485
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−
565486instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566487instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567488instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -575,13 +496,6 @@ instance ToSchema a => ToSchema (Set a) where
575496
576497instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577498
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−
585499instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586500instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587501
@@ -591,147 +505,67 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
591505instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592506instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593507
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596508-- | Default schema for @'Bounded'@, @'Integral'@ types.
597509--
598510-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599511-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
512+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
601513toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
514+ & type_ .~ SwaggerInteger
603515 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604516 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605517
606518-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
519+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
608520 ( Bounded a, Integral a
609521 , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
522+ => SchemaOptions -> proxy a -> NamedSchema
611523genericToNamedSchemaBoundedIntegral 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
524+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
668525
669526-- | 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
527+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
528+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
673529
674530-- | A configurable generic @'NamedSchema'@ creator.
675531-- This function applied to @'defaultSchemaOptions'@
676532-- is used as the default for @'declareNamedSchema'@
677533-- 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))
534+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
535+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
702536
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
537+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
538+gdatatypeSchemaName opts _ = case name of
705539 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706540 _ -> Nothing
707541 where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
709− name = datatypeNameModifier opts orig
542+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
710543
711544-- | 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)
545+paramSchemaToNamedSchema :: forall a d f proxy.
546+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
547+ => SchemaOptions -> proxy a -> NamedSchema
548+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
715549
716550-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
551+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
552+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
719553
720554nullarySchema :: Schema
721555nullarySchema = mempty
722− & type_ ?~ SwaggerArray
556+ & type_ .~ SwaggerArray
723557 & items ?~ SwaggerItemsArray []
724558
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
559+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
726560gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727561
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
562+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
729563gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730564
731565instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
732566 gdeclareNamedSchema opts _ schema = do
733− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
734− gdeclareNamedSchema opts (Proxy :: Proxy g) gschema
567+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema
568+ gdeclareNamedSchema opts (Proxy :: Proxy f) gschema
735569
736570instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
737571 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
@@ -745,7 +579,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745579 gdeclareNamedSchema = gdeclareNamedSumSchema
746580
747581-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
582+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
749583 gdeclareNamedSchema opts _ s
750584 | unwrapUnaryRecords opts = fieldSchema
751585 | otherwise =
@@ -759,7 +593,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
759593 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760594 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761595
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
596+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
763597gdeclareSchemaRef opts proxy = do
764598 case gtoNamedSchema opts proxy of
765599 NamedSchema (Just name) schema -> do
@@ -771,16 +605,16 @@ gdeclareSchemaRef opts proxy = do
771605 -- have already declared it.
772606 -- If we have, we don't need to declare anything for
773607 -- this schema this time and thus simply return the reference.
774− known <- looks (InsOrdHashMap.member name)
608+ known <- looks (HashMap.member name)
775609 when (not known) $ do
776610 declare [(name, schema)]
777611 void $ gdeclareNamedSchema opts proxy mempty
778612 return $ Ref (Reference name)
779613 _ -> Inline <$> gdeclareSchema opts proxy
780614
781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
615+appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)
782616appendItem x Nothing = Just (SwaggerItemsArray [x])
783−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
617+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))
784618appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"
785619
786620withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
@@ -790,15 +624,13 @@ withFieldSchema opts _ isRequiredField schema = do
790624 return $
791625 if T.null fname
792626 then schema
793− & type_ ?~ SwaggerArray
627+ & type_ .~ SwaggerArray
794628 & items %~ appendItem ref
795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796− & minItems %~ Just . maybe 1 (+1) -- increment minItems
797629 else schema
798− & type_ ?~ SwaggerObject
630+ & type_ .~ SwaggerObject
799631 & properties . at fname ?~ ref
800632 & if isRequiredField
801− then required %~ (++ [fname])
633+ then required %~ (fname :)
802634 else id
803635 where
804636 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))
@@ -817,13 +649,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
817649instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
818650 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819651
820−instance ( GSumToSchema f
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
652+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
824653 gdeclareNamedSchema = gdeclareNamedSumSchema
825654
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
655+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827656gdeclareNamedSumSchema opts proxy s
828657 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829658 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -832,29 +661,29 @@ gdeclareNamedSumSchema opts proxy s
832661 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833662
834663 toStringTag schema = mempty
835− & type_ ?~ SwaggerString
836− & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
664+ & type_ .~ SwaggerString
665+ & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837666
838667type AllNullary = All
839668
840−class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
669+class GSumToSchema f where
670+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842671
843672instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
673+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)
845674
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
675+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
676+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
848677gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
678+ & type_ .~ SwaggerObject
850679 & properties . at tag ?~ ref
851680 & maxProperties ?~ 1
852681 & minProperties ?~ 1
853682 where
854683 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855684
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
685+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
686+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858687gsumConToSchema opts proxy schema = do
859688 ref <- gdeclareSchemaRef opts proxy
860689 return $ gsumConToSchemaWith ref opts proxy schema
@@ -876,7 +705,3 @@ data Proxy2 a b = Proxy2
876705
877706data Proxy3 a b c = Proxy3
878707
879−-- $setup
880−-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hs+77−264
@@ -1,17 +1,15 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE GADTs #-}
75{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PackageImports #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE UndecidableInstances #-}
1513-- |
1614-- Module: Data.Swagger.Internal.Schema.Validation
1715-- Copyright: (c) 2015 GetShopTV
@@ -22,34 +20,28 @@
2220-- Validate JSON values with Swagger Schema.
2321module Data.Swagger.Internal.Schema.Validation where
2422
25−import Prelude ()
26−import Prelude.Compat
23+import Control.Applicative
24+import Control.Lens
25+import Control.Lens.TH
26+import Control.Monad (when)
2727
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
28+import Data.Aeson hiding (Result)
29+import Data.Foldable (traverse_, for_, sequenceA_)
30+import Data.HashMap.Strict (HashMap)
31+import qualified Data.HashMap.Strict as HashMap
3932import 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
33+import Data.Monoid
34+import Data.Proxy
35+import Data.Scientific (Scientific, isInteger)
36+import Data.Text (Text)
37+import qualified Data.Text as Text
38+import Data.Vector (Vector)
39+import qualified Data.Vector as Vector
40+
41+import Data.Swagger.Declare
42+import Data.Swagger.Internal
43+import Data.Swagger.Internal.Schema
44+import Data.Swagger.Lens
5345
5446-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
5547-- This can be used with QuickCheck to ensure those instances are coherent:
@@ -58,119 +50,21 @@ import Data.Swagger.Lens
5850--
5951-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
6052-- 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.
6753validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
6854validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
6955
7056-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
7157-- This can be used with QuickCheck to ensure those instances are coherent.
7258--
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
59+-- For validation without patterns see @'validateToJSON'@.
60+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>
61+ (Pattern -> Text -> Bool) -> a -> [ValidationError]
62+validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of
17163 Failed xs -> xs
17264 Passed _ -> mempty
17365 where
66+ (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
67+ js = toJSON x
17468 cfg = defaultConfig
17569 { configPatternChecker = checker
17670 , configDefinitions = defs }
@@ -199,7 +93,7 @@ instance Alternative Result where
19993instance Monad Result where
20094 return = pure
20195 Passed x >>= f = f x
202− Failed xs >>= _ = Failed xs
96+ Failed xs >>= f = Failed xs
20397
20498-- | Validation configuration.
20599data Config = Config
@@ -244,7 +138,7 @@ instance Choice Validation where
244138
245139instance Monad (Validation s) where
246140 return = pure
247− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)
141+ Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)
248142 (>>) = (*>)
249143
250144withConfig :: (Config -> Validation s a) -> Validation s a
@@ -263,17 +157,11 @@ valid = pure ()
263157
264158-- | Validate schema's property given a lens into that property
265159-- 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.
275160check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
276−check = checkMissing valid
161+check l g = withSchema $ \schema ->
162+ case schema ^. l of
163+ Nothing -> valid
164+ Just x -> g x
277165
278166-- | Validate same value with different schema.
279167sub :: t -> Validation t a -> Validation s a
@@ -286,12 +174,12 @@ sub_ = lmap . view
286174-- | Validate value against a schema given schema reference and validation function.
287175withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
288176withRef (Reference ref) f = withConfig $ \cfg ->
289− case InsOrdHashMap.lookup ref (configDefinitions cfg) of
177+ case HashMap.lookup ref (configDefinitions cfg) of
290178 Nothing -> invalid $ "unknown schema " ++ show ref
291179 Just s -> f s
292180
293181validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
294−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)
182+validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)
295183validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
296184
297185-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
@@ -313,9 +201,9 @@ validateInteger n = do
313201 validateNumber n
314202
315203validateNumber :: 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
204+validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do
205+ let exMax = Just True == schema ^. exclusiveMaximum
206+ exMin = Just True == schema ^. exclusiveMinimum
319207
320208 check maximum_ $ \m ->
321209 when (if exMax then (n >= m) else (n > m)) $
@@ -372,8 +260,8 @@ validateArray xs = do
372260 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
373261
374262validateObject :: HashMap Text Value -> Validation Schema ()
375−validateObject o = withSchema $ \sch ->
376− case sch ^. discriminator of
263+validateObject o = withSchema $ \schema ->
264+ case schema ^. discriminator of
377265 Just pname -> case fromJSON <$> HashMap.lookup pname o of
378266 Just (Success ref) -> validateWithSchemaRef ref (Object o)
379267 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
@@ -392,120 +280,45 @@ validateObject o = withSchema $ \sch ->
392280 where
393281 size = fromIntegral (HashMap.size o)
394282
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))
283+ validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)
284+ validateReq name =
285+ when (not (HashMap.member name o)) $
286+ invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))
399287
400− validateProps = withSchema $ \sch -> do
288+ validateProps = withSchema $ \schema -> do
401289 for_ (HashMap.toList o) $ \(k, v) ->
402290 case v of
403− Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
291+ Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property
404292 _ ->
405− case InsOrdHashMap.lookup k (sch ^. properties) of
406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
293+ case HashMap.lookup k (schema ^. properties) of
294+ Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v
407295 Just s -> validateWithSchemaRef s v
408296
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−
417297validateEnum :: Value -> Validation (ParamSchema t) ()
418298validateEnum value = do
419299 check enum_ $ \xs ->
420300 when (value `notElem` xs) $
421301 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
422302
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−
470303validateSchemaType :: 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
304+validateSchemaType value = withSchema $ \schema ->
305+ case (schema ^. type_, value) of
306+ (SwaggerNull, Null) -> valid
307+ (SwaggerBoolean, Bool _) -> valid
308+ (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
309+ (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
310+ (SwaggerString, String s) -> sub_ paramSchema (validateString s)
311+ (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
312+ (SwaggerObject, Object o) -> validateObject o
313+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
488314
489315validateParamSchemaType :: 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"
316+validateParamSchemaType value = withSchema $ \schema ->
317+ case (schema ^. type_, value) of
318+ (SwaggerBoolean, Bool _) -> valid
319+ (SwaggerInteger, Number n) -> validateInteger n
320+ (SwaggerNumber, Number n) -> validateNumber n
321+ (SwaggerString, String s) -> validateString s
322+ (SwaggerArray, Array xs) -> validateArray xs
323+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
324+
src/Data/Swagger/Internal/TypeShape.hsdeleted−66
@@ -1,66 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−
9−module Data.Swagger.Internal.TypeShape where
10−
11−import Data.Proxy
12−import GHC.Generics
13−import GHC.TypeLits
14−import GHC.Exts (Constraint)
15−
16−-- | Shape of a datatype.
17−data TypeShape
18− = Enumeration -- ^ A simple enumeration.
19− | SumOfProducts -- ^ A product or a sum of non-unit products.
20− | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
21−
22−-- | A combined shape for a product type.
23−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
24− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
25− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
26− ProdCombine a b = SumOfProducts
27−
28−-- | A combined shape for a sum type.
29−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
30− SumCombine Enumeration Enumeration = Enumeration
31− SumCombine SumOfProducts SumOfProducts = SumOfProducts
32− SumCombine a b = Mixed
33−
34−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
35− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
36−
37−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
38− GenericHasSimpleShape t f Enumeration = ()
39− GenericHasSimpleShape t f SumOfProducts = ()
40−#if __GLASGOW_HASKELL__ < 800
41− GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t
42−
43−class CannotDeriveSchemaForMixedSumType t where
44−#else
45− GenericHasSimpleShape t f Mixed =
46− TypeError
47− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
48− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
49− :$$: Text "Swagger does not have a good representation for these types."
50− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
51− :$$: Text "that matches aeson's Generic-based toJSON,"
52− :$$: Text "but that's not supported by some Swagger tools."
53− )
54−#endif
55−
56−-- | Infer a 'TypeShape' for a generic representation of a type.
57−type family GenericShape (g :: * -> *) :: TypeShape
58−
59−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
60−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
61−type instance GenericShape (D1 d f) = GenericShape f
62−type instance GenericShape (C1 c U1) = Enumeration
63−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
64−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
65−
66−
src/Data/Swagger/Internal/Utils.hs+46−6
@@ -9,6 +9,8 @@ module Data.Swagger.Internal.Utils where
99import Prelude ()
1010import Prelude.Compat
1111
12+import Control.Arrow (first)
13+import Control.Applicative
1214import Control.Lens ((&), (%~))
1315import Control.Lens.TH
1416import Data.Aeson
@@ -18,13 +20,13 @@ import Data.Data
1820import Data.Hashable (Hashable)
1921import Data.HashMap.Strict (HashMap)
2022import qualified Data.HashMap.Strict as HashMap
21−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
2323import Data.Map (Map)
24+import Data.Monoid
2425import Data.Set (Set)
2526import Data.Text (Text)
2627import GHC.Generics
2728import Language.Haskell.TH (mkName)
29+import Text.Read (readMaybe)
2830
2931swaggerFieldRules :: LensRules
3032swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer
@@ -51,6 +53,17 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of
5153 Just x -> z x
5254 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."
5355
56+hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v
57+hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList
58+
59+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)
60+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList
61+ where
62+ g (x, y) = (\a -> (a, y)) <$> f x
63+
64+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)
65+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)
66+
5467jsonPrefix :: String -> Options
5568jsonPrefix prefix = defaultOptions
5669 { fieldLabelModifier = modifier . drop 1
@@ -72,10 +85,40 @@ parseOneOf xs js =
7285 where
7386 ys = zip (map toJSON xs) xs
7487
88+omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value
89+omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)
90+ where
91+ nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)
92+omitEmptiesExcept _ js = js
93+
94+omitEmpties :: Value -> Value
95+omitEmpties = omitEmptiesExcept (\_ _ -> False)
96+
97+genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value
98+genericToJSONWithSub sub opts x =
99+ case genericToJSON opts x of
100+ Object o ->
101+ case HashMap.lookup sub o of
102+ Just so -> Object (HashMap.delete sub o) <+> so
103+ Nothing -> Object o -- no subjson, leaving object as is
104+ _ -> error "genericToJSONWithSub: subjson is not an object"
105+
106+genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a
107+genericParseJSONWithSub sub opts js@(Object o)
108+ = genericParseJSON opts js -- try without subjson
109+ <|> genericParseJSON opts js' -- try with subjson
110+ where
111+ js' = Object (HashMap.insert sub (Object o) o)
112+genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"
113+
75114(<+>) :: Value -> Value -> Value
76115Object x <+> Object y = Object (x <> y)
77116_ <+> _ = error "<+>: merging non-objects"
78117
118+withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a
119+withDefaults parser defs js@(Object _) = parser (js <+> object defs)
120+withDefaults _ _ _ = empty
121+
79122genericMempty :: (Generic a, GMonoid (Rep a)) => a
80123genericMempty = to gmempty
81124
@@ -118,10 +161,6 @@ instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where
118161 swaggerMempty = mempty
119162 swaggerMappend = HashMap.unionWith (\_old new -> new)
120163
121−instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where
122− swaggerMempty = mempty
123− swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)
124−
125164instance SwaggerMonoid Text where
126165 swaggerMempty = mempty
127166 swaggerMappend x "" = x
@@ -131,3 +170,4 @@ instance SwaggerMonoid (Maybe a) where
131170 swaggerMempty = Nothing
132171 swaggerMappend x Nothing = x
133172 swaggerMappend _ y = y
173+
src/Data/Swagger/Lens.hs+9−20
@@ -7,7 +7,6 @@
77{-# LANGUAGE RankNTypes #-}
88{-# LANGUAGE TemplateHaskell #-}
99{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE DataKinds #-}
1110{-# LANGUAGE UndecidableInstances #-}
1211{-# OPTIONS_GHC -fno-warn-orphans #-}
1312#include "overlapping-compat.h"
@@ -60,23 +59,19 @@ makePrisms ''Referenced
6059
6160-- ** 'SwaggerItems' prisms
6261
63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]
62+_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]
6463_SwaggerItemsArray
65− = unto (\x -> SwaggerItemsArray x)
66−{- \x -> case x of
64+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of
6765 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
6866 SwaggerItemsObject o -> Left (SwaggerItemsObject o)
6967 SwaggerItemsArray a -> Right a
70−-}
7168
72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)
69+_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)
7370_SwaggerItemsObject
74− = unto (\x -> SwaggerItemsObject x)
75−{- \x -> case x of
71+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of
7672 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)
7773 SwaggerItemsObject o -> Right o
7874 SwaggerItemsArray a -> Left (SwaggerItemsArray a)
79−-}
8075
8176_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)
8277_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)
@@ -96,19 +91,13 @@ instance At Responses where at n = responses . at n
9691instance Ixed Operation where ix n = responses . ix n
9792instance At Operation where at n = responses . at n
9893
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
94+instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema
10695
10796-- 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_
97+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_
98+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_
99+instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_
100+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_
112101
113102-- HasDefault instances
114103instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
src/Data/Swagger/Operation.hs+19−18
@@ -30,24 +30,22 @@ module Data.Swagger.Operation (
3030 declareResponse,
3131) where
3232
33−import Prelude ()
34−import Prelude.Compat
35−
33+import Control.Applicative
34+import Control.Arrow
3635import Control.Lens
3736import Data.Data.Lens
38−import Data.List.Compat
37+import qualified Data.HashMap.Strict as HashMap
38+import Data.List
3939import Data.Maybe (mapMaybe)
40−import Data.Proxy
40+import Data.Monoid
4141import qualified Data.Set as Set
42+import Data.Traversable
4243
4344import Data.Swagger.Declare
4445import Data.Swagger.Internal
4546import Data.Swagger.Lens
4647import Data.Swagger.Schema
4748
48−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49−import qualified Data.HashSet.InsOrd as InsOrdHS
50−
5149-- $setup
5250-- >>> import Data.Aeson
5351-- >>> import Data.Proxy
@@ -60,8 +58,10 @@ import qualified Data.HashSet.InsOrd as InsOrdHS
6058-- >>> encode $ prependPath "user/{user_id}" api ^. paths
6159-- "{\"/user/{user_id}/info\":{}}"
6260prependPath :: FilePath -> Swagger -> Swagger
63−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
61+prependPath path = paths %~ mapKeys (path </>)
6462 where
63+ mapKeys f = HashMap.fromList . map (first f) . HashMap.toList
64+
6565 x </> y = case trim y of
6666 "" -> "/" <> trim x
6767 y' -> "/" <> trim x <> "/" <> y'
@@ -80,15 +80,15 @@ allOperations = paths.traverse.template
8080-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
8181-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
8282-- >>> encode api
83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
83+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
8484-- >>> 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\"}}}}}}"
85+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"
8686operationsOf :: Swagger -> Traversal' Swagger Operation
8787operationsOf sub = paths.itraversed.withIndex.subops
8888 where
8989 -- | Traverse operations that correspond to paths and methods of the sub API.
9090 subops :: Traversal' (FilePath, PathItem) Operation
91− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of
91+ subops f (path, item) = case HashMap.lookup path (sub ^. paths) of
9292 Just subitem -> (,) path <$> methodsOf subitem f item
9393 Nothing -> pure (path, item)
9494
@@ -112,15 +112,15 @@ applyTags = applyTagsFor allOperations
112112-- list of tags.
113113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
114114applyTagsFor ops ts swag = swag
115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
116− & tags %~ (<> InsOrdHS.fromList ts)
115+ & ops . tags %~ (<> Set.fromList (map _tagName ts))
116+ & tags %~ (<> Set.fromList ts)
117117
118118-- | Construct a response with @'Schema'@ while declaring all
119119-- necessary schema definitions.
120120--
121121-- >>> 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
122+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"
123+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
124124declareResponse proxy = do
125125 s <- declareSchemaRef proxy
126126 return (mempty & schema ?~ s)
@@ -139,7 +139,7 @@ declareResponse proxy = do
139139-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
140140-- >>> let res = declareResponse (Proxy :: Proxy Day)
141141-- >>> 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\"}}}"
142+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"
143143--
144144-- See also @'setResponseWith'@.
145145setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
@@ -186,8 +186,9 @@ setResponseForWith ops f code dres swag = swag
186186 where
187187 (defs, new) = runDeclare dres mempty
188188
189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of
189+ combine (Just (Ref (Reference name))) = case swag ^. responses.at name of
190190 Just old -> f old new
191191 Nothing -> new -- response name can't be dereferenced, replacing with new response
192192 combine (Just (Inline old)) = f old new
193193 combine Nothing = new
194+
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/Schema.hs−15
@@ -17,25 +17,11 @@ module Data.Swagger.Schema (
1717 -- * Generic schema encoding
1818 genericDeclareNamedSchema,
1919 genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
2420 genericToNamedSchemaBoundedIntegral,
2521 toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
3222 paramSchemaToNamedSchema,
3323 paramSchemaToSchema,
3424
35− -- ** Unrestricted versions
36− genericDeclareNamedSchemaUnrestricted,
37− genericDeclareSchemaUnrestricted,
38−
3925 -- * Schema templates
4026 passwordSchema,
4127 binarySchema,
@@ -54,7 +40,6 @@ module Data.Swagger.Schema (
5440 -- * Generic encoding configuration
5541 SchemaOptions(..),
5642 defaultSchemaOptions,
57− fromAesonOptions,
5843) where
5944
6045import Data.Swagger.Internal.Schema
src/Data/Swagger/Schema/Generator.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.Schema.Generator where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens.Operators
11−import Control.Monad (filterM)
12−import Data.Aeson
13−import Data.Aeson.Types
14−import qualified Data.HashMap.Strict.InsOrd as M
15−import Data.Maybe
16−import Data.Maybe
17−import Data.Proxy
18−import Data.Scientific
19−import qualified Data.Set as S
20−import Data.Swagger
21−import Data.Swagger.Declare
22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)
23−import qualified Data.Text as T
24−import qualified Data.Vector as V
25−import Test.QuickCheck (arbitrary)
26−import Test.QuickCheck.Gen
27−import Test.QuickCheck.Property
28−
29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30−-- and cannot be inferred.
31−schemaGen :: Definitions Schema -> Schema -> Gen Value
32−schemaGen _ schema
33− | Just cases <- schema ^. paramSchema . enum_ = elements cases
34−schemaGen defns schema =
35− case schema ^. type_ of
36− Nothing ->
37− case inferSchemaTypes schema of
38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
39− -- Gen is not MonadFail
40− _ -> error "unable to infer schema type"
41− Just SwaggerBoolean -> Bool <$> elements [True, False]
42− Just SwaggerNull -> pure Null
43− Just SwaggerNumber
44− | Just min <- schema ^. minimum_
45− , Just max <- schema ^. maximum_ ->
46− Number . fromFloatDigits <$>
47− choose (toRealFloat min, toRealFloat max :: Double)
48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
49− Just SwaggerInteger
50− | Just min <- schema ^. minimum_
51− , Just max <- schema ^. maximum_ ->
52− Number . fromInteger <$>
53− choose (truncate min, truncate max)
54− | otherwise -> Number . fromInteger <$> arbitrary
55− Just SwaggerArray
56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
57− | Just items <- schema ^. items ->
58− case items of
59− SwaggerItemsObject ref -> do
60− size <- getSize
61− let itemSchema = dereference defns ref
62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
64− arrayLength <- choose (minLength', max minLength' maxLength')
65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
66− return . Array $ V.fromList generatedArray
67− SwaggerItemsArray refs ->
68− let itemGens = schemaGen defns . dereference defns <$> refs
69− in fmap (Array . V.fromList) $ sequence itemGens
70− Just SwaggerString -> do
71− size <- getSize
72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
74− length <- choose (minLength', max minLength' maxLength')
75− str <- vectorOf length arbitrary
76− return . String $ T.pack str
77− Just SwaggerObject -> do
78− size <- getSize
79− let props = dereference defns <$> schema ^. properties
80− reqKeys = S.fromList $ schema ^. required
81− allKeys = S.fromList . M.keys $ schema ^. properties
82− optionalKeys = allKeys S.\\ reqKeys
83− minProps' = fromMaybe (length reqKeys) $
84− fromInteger <$> schema ^. minProperties
85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
86− shuffledOptional <- shuffle $ S.toList optionalKeys
87− numProps <- choose (minProps', max minProps' maxProps')
88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
90− let gens = schemaGen defns <$> presentProps
91− additionalGens <- case schema ^. additionalProperties of
92− Just (AdditionalPropertiesSchema addlSchema) -> do
93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
95− _ -> return []
96− x <- sequence $ gens <> additionalGens
97− return . Object $ M.toHashMap x
98− where
99− dereference :: Definitions a -> Referenced a -> a
100− dereference _ (Inline a) = a
101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
102−
103−genValue :: (ToSchema a) => Proxy a -> Gen Value
104−genValue p =
105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
106− in schemaGen defs schema
107−
108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
109−validateFromJSON p = forAll (genValue p) $
110− \val -> case parseEither parseJSON val of
111− Right (_ :: a) -> succeeded
112− Left err -> failed
113− { reason = err
114− }
src/Data/Swagger/Schema/Validation.hs+1−10
@@ -15,18 +15,9 @@ module Data.Swagger.Schema.Validation (
1515 -- $maybe
1616
1717 -- * JSON validation
18−
19− ValidationError,
20−
21− -- ** Using 'ToJSON' and 'ToSchema'
22− validatePrettyToJSON,
2318 validateToJSON,
2419 validateToJSONWithPatternChecker,
25− renderValidationErrors,
26−
27− -- ** Using 'Value' and 'Schema'
28− validateJSON,
29− validateJSONWithPatternChecker,
20+ ValidationError,
3021) where
3122
3223import Data.Swagger.Internal.Schema.Validation
src/Data/Swagger/SchemaOptions.hs−29
@@ -1,4 +1,3 @@
1−{-# LANGUAGE RecordWildCards #-}
21-- |
32-- Module: Data.Swagger.SchemaOptions
43-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -7,8 +6,6 @@
76-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
87module Data.Swagger.SchemaOptions where
98
10−import qualified Data.Aeson.Types as Aeson
11−
129-- | Options that specify how to encode your type to Swagger schema.
1310data SchemaOptions = SchemaOptions
1411 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
@@ -44,29 +41,3 @@ defaultSchemaOptions = SchemaOptions
4441 , unwrapUnaryRecords = False
4542 }
4643
47−-- | Convert 'Aeson.Options' to 'SchemaOptions'.
48−--
49−-- Specifically the following fields get copied:
50−--
51−-- * 'fieldLabelModifier'
52−-- * 'constructorTagModifier'
53−-- * 'allNullaryToStringTag'
54−-- * 'unwrapUnaryRecords'
55−--
56−-- Note that these fields have no effect on `SchemaOptions`:
57−--
58−-- * 'Aeson.omitNothingFields'
59−-- * 'Aeson.sumEncoding'
60−-- * 'Aeson.tagSingleConstructors'
61−--
62−-- The rest is defined as in 'defaultSchemaOptions'.
63−--
64−-- @since 2.2.1
65−--
66−fromAesonOptions :: Aeson.Options -> SchemaOptions
67−fromAesonOptions opts = defaultSchemaOptions
68− { fieldLabelModifier = Aeson.fieldLabelModifier opts
69− , constructorTagModifier = Aeson.constructorTagModifier opts
70− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts
71− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts
72− }
stack-lts-2.yamlnew file+5
@@ -0,0 +1,5 @@
1+flags: {}
2+packages:
3+- '.'
4+extra-deps: []
5+resolver: lts-2.22
stack.yaml+3−7
@@ -1,9 +1,5 @@
1−resolver: lts-14.3
1+flags: {}
22packages:
33- '.'
4−extra-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
4+extra-deps: []
5+resolver: nightly-2016-01-26
swagger2.cabal+41−99
@@ -1,15 +1,7 @@
1−cabal-version: >=1.10
21name: swagger2
3−version: 2.5
4−
2+version: 2.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
146bug-reports: https://github.com/GetShopTV/swagger2/issues
157license: BSD3
@@ -17,22 +9,15 @@ license-file: LICENSE
179author: Nickolay Kudasov
1810maintainer: nickolay@getshoptv.com
1911copyright: (c) 2015-2016, GetShopTV
20−build-type: Custom
12+category: Web
13+build-type: Simple
2114extra-source-files:
2215 README.md
2316 , CHANGELOG.md
2417 , examples/*.hs
2518 , 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
19+cabal-version: >=1.10
20+tested-with: GHC==7.8.4, GHC==7.10.3
3621
3722library
3823 hs-source-dirs: src
@@ -42,10 +27,8 @@ library
4227 Data.Swagger.Declare
4328 Data.Swagger.Lens
4429 Data.Swagger.Operation
45− Data.Swagger.Optics
4630 Data.Swagger.ParamSchema
4731 Data.Swagger.Schema
48− Data.Swagger.Schema.Generator
4932 Data.Swagger.Schema.Validation
5033 Data.Swagger.SchemaOptions
5134
@@ -55,98 +38,57 @@ library
5538 Data.Swagger.Internal.Schema.Validation
5639 Data.Swagger.Internal.ParamSchema
5740 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−
41+ build-depends: base >=4.7 && <4.10
42+ , base-compat >=0.6.0 && <0.10
43+ , aeson
44+ , containers
45+ , hashable
46+ , http-media
47+ , lens
48+ , mtl
49+ , network
50+ , scientific
51+ , text
52+ , template-haskell
53+ , time
54+ , transformers
55+ , unordered-containers
56+ , vector
9657 default-language: Haskell2010
9758
9859test-suite spec
9960 type: exitcode-stdio-1.0
10061 hs-source-dirs: test
10162 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−
63+ build-depends: base
64+ , base-compat
65+ , aeson
66+ , aeson-qq
67+ , containers
68+ , hashable
69+ , hspec
70+ , HUnit
71+ , mtl
72+ , QuickCheck
73+ , swagger2
74+ , text
75+ , time
76+ , unordered-containers
77+ , vector
78+ , lens
13479 other-modules:
13580 SpecCommon
13681 Data.SwaggerSpec
137− Data.Swagger.CommonTestTypes
13882 Data.Swagger.ParamSchemaSpec
13983 Data.Swagger.SchemaSpec
14084 Data.Swagger.Schema.ValidationSpec
141− Data.Swagger.Schema.GeneratorSpec
14285 default-language: Haskell2010
14386
144−test-suite doctests
145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
146− build-depends: base, doctest, Glob, QuickCheck
87+test-suite doctest
88+ build-depends: base, doctest, Glob
14789 default-language: Haskell2010
14890 hs-source-dirs: test
149− main-is: doctests.hs
91+ main-is: DocTest.hs
15092 type: exitcode-stdio-1.0
15193
15294source-repository head
test/Data/Swagger/CommonTestTypes.hsdeleted−679
@@ -1,679 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE QuasiQuotes #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.CommonTestTypes where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)
11−import Data.Aeson.QQ.Simple
12−import Data.Aeson.Types (toJSONKeyText)
13−import Data.Char
14−import Data.Map (Map)
15−import Data.Proxy
16−import Data.Set (Set)
17−import qualified Data.Text as Text
18−import GHC.Generics
19−
20−import Data.Swagger
21−
22−-- ========================================================================
23−-- Unit type
24−-- ========================================================================
25−
26−data Unit = Unit deriving (Generic)
27−instance ToParamSchema Unit
28−instance ToSchema Unit
29−
30−unitSchemaJSON :: Value
31−unitSchemaJSON = [aesonQQ|
32−{
33− "type": "string",
34− "enum": ["Unit"]
35−}
36−|]
37−
38−-- ========================================================================
39−-- Color (enum)
40−-- ========================================================================
41−data Color
42− = Red
43− | Green
44− | Blue
45− deriving (Generic)
46−instance ToParamSchema Color
47−instance ToSchema Color
48−
49−colorSchemaJSON :: Value
50−colorSchemaJSON = [aesonQQ|
51−{
52− "type": "string",
53− "enum": ["Red", "Green", "Blue"]
54−}
55−|]
56−
57−-- ========================================================================
58−-- Shade (paramSchemaToNamedSchema)
59−-- ========================================================================
60−
61−data Shade = Dim | Bright deriving (Generic)
62−instance ToParamSchema Shade
63−
64−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
65−
66−shadeSchemaJSON :: Value
67−shadeSchemaJSON = [aesonQQ|
68−{
69− "type": "string",
70− "enum": ["Dim", "Bright"]
71−}
72−|]
73−
74−-- ========================================================================
75−-- Paint (record with bounded enum property)
76−-- ========================================================================
77−
78−newtype Paint = Paint { color :: Color }
79− deriving (Generic)
80−instance ToSchema Paint
81−
82−paintSchemaJSON :: Value
83−paintSchemaJSON = [aesonQQ|
84−{
85− "type": "object",
86− "properties":
87− {
88− "color":
89− {
90− "$ref": "#/definitions/Color"
91− }
92− },
93− "required": ["color"]
94−}
95−|]
96−
97−paintInlinedSchemaJSON :: Value
98−paintInlinedSchemaJSON = [aesonQQ|
99−{
100− "type": "object",
101− "properties":
102− {
103− "color":
104− {
105− "type": "string",
106− "enum": ["Red", "Green", "Blue"]
107− }
108− },
109− "required": ["color"]
110−}
111−|]
112−
113−-- ========================================================================
114−-- Status (constructorTagModifier)
115−-- ========================================================================
116−
117−data Status
118− = StatusOk
119− | StatusError
120− deriving (Generic)
121−
122−instance ToParamSchema Status where
123− toParamSchema = genericToParamSchema defaultSchemaOptions
124− { constructorTagModifier = map toLower . drop (length "Status") }
125−instance ToSchema Status where
126− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
127− { constructorTagModifier = map toLower . drop (length "Status") }
128−
129−statusSchemaJSON :: Value
130−statusSchemaJSON = [aesonQQ|
131−{
132− "type": "string",
133− "enum": ["ok", "error"]
134−}
135−|]
136−
137−-- ========================================================================
138−-- Email (newtype with unwrapUnaryRecords set to True)
139−-- ========================================================================
140−
141−newtype Email = Email { getEmail :: String }
142− deriving (Generic)
143−instance ToParamSchema Email
144−instance ToSchema Email where
145− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
146− { unwrapUnaryRecords = True }
147−
148−emailSchemaJSON :: Value
149−emailSchemaJSON = [aesonQQ|
150−{
151− "type": "string"
152−}
153−|]
154−
155−-- ========================================================================
156−-- UserId (non-record newtype)
157−-- ========================================================================
158−
159−newtype UserId = UserId Integer
160− deriving (Eq, Ord, Generic)
161−instance ToParamSchema UserId
162−instance ToSchema UserId
163−
164−userIdSchemaJSON :: Value
165−userIdSchemaJSON = [aesonQQ|
166−{
167− "type": "integer"
168−}
169−|]
170−
171−-- ========================================================================
172−-- UserGroup (set newtype)
173−-- ========================================================================
174−
175−newtype UserGroup = UserGroup (Set UserId)
176− deriving (Generic)
177−instance ToSchema UserGroup
178−
179−userGroupSchemaJSON :: Value
180−userGroupSchemaJSON = [aesonQQ|
181−{
182− "type": "array",
183− "items": { "$ref": "#/definitions/UserId" },
184− "uniqueItems": true
185−}
186−|]
187−
188−-- ========================================================================
189−-- Person (simple record with optional fields)
190−-- ========================================================================
191−data Person = Person
192− { name :: String
193− , phone :: Integer
194− , email :: Maybe String
195− } deriving (Generic)
196−
197−instance ToSchema Person
198−
199−personSchemaJSON :: Value
200−personSchemaJSON = [aesonQQ|
201−{
202− "type": "object",
203− "properties":
204− {
205− "name": { "type": "string" },
206− "phone": { "type": "integer" },
207− "email": { "type": "string" }
208− },
209− "required": ["name", "phone"]
210−}
211−|]
212−
213−-- ========================================================================
214−-- Player (record newtype)
215−-- ========================================================================
216−
217−newtype Player = Player
218− { position :: Point
219− } deriving (Generic)
220−instance ToSchema Player
221−
222−playerSchemaJSON :: Value
223−playerSchemaJSON = [aesonQQ|
224−{
225− "type": "object",
226− "properties":
227− {
228− "position":
229− {
230− "$ref": "#/definitions/Point"
231− }
232− },
233− "required": ["position"]
234−}
235−|]
236−
237−newtype Players = Players [Inlined Player]
238− deriving (Generic)
239−instance ToSchema Players
240−
241−playersSchemaJSON :: Value
242−playersSchemaJSON = [aesonQQ|
243−{
244− "type": "array",
245− "items":
246− {
247− "type": "object",
248− "properties":
249− {
250− "position":
251− {
252− "$ref": "#/definitions/Point"
253− }
254− },
255− "required": ["position"]
256− }
257−}
258−|]
259−
260−-- ========================================================================
261−-- Character (sum type with ref and record in alternative)
262−-- ========================================================================
263−
264−data Character
265− = PC Player
266− | NPC { npcName :: String, npcPosition :: Point }
267− deriving (Generic)
268−instance ToSchema Character
269−
270−characterSchemaJSON :: Value
271−characterSchemaJSON = [aesonQQ|
272−{
273− "type": "object",
274− "properties":
275− {
276− "PC": { "$ref": "#/definitions/Player" },
277− "NPC":
278− {
279− "type": "object",
280− "properties":
281− {
282− "npcName": { "type": "string" },
283− "npcPosition": { "$ref": "#/definitions/Point" }
284− },
285− "required": ["npcName", "npcPosition"]
286− }
287− },
288− "maxProperties": 1,
289− "minProperties": 1
290−}
291−|]
292−
293−characterInlinedSchemaJSON :: Value
294−characterInlinedSchemaJSON = [aesonQQ|
295−{
296− "type": "object",
297− "properties":
298− {
299− "PC":
300− {
301− "type": "object",
302− "properties":
303− {
304− "position":
305− {
306− "type": "object",
307− "properties":
308− {
309− "x": { "type": "number", "format": "double" },
310− "y": { "type": "number", "format": "double" }
311− },
312− "required": ["x", "y"]
313− }
314− },
315− "required": ["position"]
316− },
317− "NPC":
318− {
319− "type": "object",
320− "properties":
321− {
322− "npcName": { "type": "string" },
323− "npcPosition":
324− {
325− "type": "object",
326− "properties":
327− {
328− "x": { "type": "number", "format": "double" },
329− "y": { "type": "number", "format": "double" }
330− },
331− "required": ["x", "y"]
332− }
333− },
334− "required": ["npcName", "npcPosition"]
335− }
336− },
337− "maxProperties": 1,
338− "minProperties": 1
339−}
340−|]
341−
342−characterInlinedPlayerSchemaJSON :: Value
343−characterInlinedPlayerSchemaJSON = [aesonQQ|
344−{
345− "type": "object",
346− "properties":
347− {
348− "PC":
349− {
350− "type": "object",
351− "properties":
352− {
353− "position":
354− {
355− "$ref": "#/definitions/Point"
356− }
357− },
358− "required": ["position"]
359− },
360− "NPC":
361− {
362− "type": "object",
363− "properties":
364− {
365− "npcName": { "type": "string" },
366− "npcPosition": { "$ref": "#/definitions/Point" }
367− },
368− "required": ["npcName", "npcPosition"]
369− }
370− },
371− "maxProperties": 1,
372− "minProperties": 1
373−}
374−|]
375−
376−-- ========================================================================
377−-- ISPair (non-record product data type)
378−-- ========================================================================
379−data ISPair = ISPair Integer String
380− deriving (Generic)
381−
382−instance ToSchema ISPair
383−
384−ispairSchemaJSON :: Value
385−ispairSchemaJSON = [aesonQQ|
386−{
387− "type": "array",
388− "items":
389− [
390− { "type": "integer" },
391− { "type": "string" }
392− ],
393− "minItems": 2,
394− "maxItems": 2
395−}
396−|]
397−
398−-- ========================================================================
399−-- Point (record data type with custom fieldLabelModifier)
400−-- ========================================================================
401−
402−data Point = Point
403− { pointX :: Double
404− , pointY :: Double
405− } deriving (Generic)
406−
407−instance ToSchema Point where
408− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
409− { fieldLabelModifier = map toLower . drop (length "point") }
410−
411−pointSchemaJSON :: Value
412−pointSchemaJSON = [aesonQQ|
413−{
414− "type": "object",
415− "properties":
416− {
417− "x": { "type": "number", "format": "double" },
418− "y": { "type": "number", "format": "double" }
419− },
420− "required": ["x", "y"]
421−}
422−|]
423−
424−-- ========================================================================
425−-- Point (record data type with multiple fields)
426−-- ========================================================================
427−
428−data Point5 = Point5
429− { point5X :: Double
430− , point5Y :: Double
431− , point5Z :: Double
432− , point5U :: Double
433− , point5V :: Double -- 5 dimensional!
434− } deriving (Generic)
435−
436−instance ToSchema Point5 where
437− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
438− { fieldLabelModifier = map toLower . drop (length "point5") }
439−
440−point5SchemaJSON :: Value
441−point5SchemaJSON = [aesonQQ|
442−{
443− "type": "object",
444− "properties":
445− {
446− "x": { "type": "number", "format": "double" },
447− "y": { "type": "number", "format": "double" },
448− "z": { "type": "number", "format": "double" },
449− "u": { "type": "number", "format": "double" },
450− "v": { "type": "number", "format": "double" }
451− },
452− "required": ["x", "y", "z", "u", "v"]
453−}
454−|]
455−
456−point5Properties :: [String]
457−point5Properties = ["x", "y", "z", "u", "v"]
458−
459−-- ========================================================================
460−-- MyRoseTree (custom datatypeNameModifier)
461−-- ========================================================================
462−
463−data MyRoseTree = MyRoseTree
464− { root :: String
465− , trees :: [MyRoseTree]
466− } deriving (Generic)
467−
468−instance ToSchema MyRoseTree where
469− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
470− { datatypeNameModifier = drop (length "My") }
471−
472−myRoseTreeSchemaJSON :: Value
473−myRoseTreeSchemaJSON = [aesonQQ|
474−{
475− "type": "object",
476− "properties":
477− {
478− "root": { "type": "string" },
479− "trees":
480− {
481− "type": "array",
482− "items":
483− {
484− "$ref": "#/definitions/RoseTree"
485− }
486− }
487− },
488− "required": ["root", "trees"]
489−}
490−|]
491−
492−data MyRoseTree' = MyRoseTree'
493− { root' :: String
494− , trees' :: [MyRoseTree']
495− } deriving (Generic)
496−
497−instance ToSchema MyRoseTree' where
498− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
499− { datatypeNameModifier = map toLower }
500−
501−myRoseTreeSchemaJSON' :: Value
502−myRoseTreeSchemaJSON' = [aesonQQ|
503−{
504− "type": "object",
505− "properties":
506− {
507− "root'": { "type": "string" },
508− "trees'":
509− {
510− "type": "array",
511− "items":
512− {
513− "$ref": "#/definitions/myrosetree'"
514− }
515− }
516− },
517− "required": ["root'", "trees'"]
518−}
519−|]
520−
521−-- ========================================================================
522−-- Inlined (newtype for inlining schemas)
523−-- ========================================================================
524−
525−newtype Inlined a = Inlined { getInlined :: a }
526−
527−instance ToSchema a => ToSchema (Inlined a) where
528− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
529− where
530− unname (NamedSchema _ s) = NamedSchema Nothing s
531−
532−-- ========================================================================
533−-- Light (sum type with unwrapUnaryRecords)
534−-- ========================================================================
535−
536−data Light
537− = NoLight
538− | LightFreq Double
539− | LightColor Color
540− | LightWaveLength { waveLength :: Double }
541− deriving (Generic)
542−
543−instance ToSchema Light where
544− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
545− { unwrapUnaryRecords = True }
546−
547−lightSchemaJSON :: Value
548−lightSchemaJSON = [aesonQQ|
549−{
550− "type": "object",
551− "properties":
552− {
553− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
554− "LightFreq": { "type": "number", "format": "double" },
555− "LightColor": { "$ref": "#/definitions/Color" },
556− "LightWaveLength": { "type": "number", "format": "double" }
557− },
558− "maxProperties": 1,
559− "minProperties": 1
560−}
561−|]
562−
563−lightInlinedSchemaJSON :: Value
564−lightInlinedSchemaJSON = [aesonQQ|
565−{
566− "type": "object",
567− "properties":
568− {
569− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
570− "LightFreq": { "type": "number", "format": "double" },
571− "LightColor":
572− {
573− "type": "string",
574− "enum": ["Red", "Green", "Blue"]
575− },
576− "LightWaveLength": { "type": "number", "format": "double" }
577− },
578− "maxProperties": 1,
579− "minProperties": 1
580−}
581−|]
582−
583−-- ========================================================================
584−-- ResourceId (series of newtypes)
585−-- ========================================================================
586−
587−newtype Id = Id String deriving (Generic)
588−instance ToSchema Id
589−
590−newtype ResourceId = ResourceId Id deriving (Generic)
591−instance ToSchema ResourceId
592−
593−-- ========================================================================
594−-- ButtonImages (bounded enum key mapping)
595−-- ========================================================================
596−
597−data ButtonState = Neutral | Focus | Active | Hover | Disabled
598− deriving (Show, Bounded, Enum, Generic)
599−
600−instance ToJSON ButtonState
601−instance ToSchema ButtonState
602−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
603−
604−type ImageUrl = Text.Text
605−
606−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
607− deriving (Generic)
608−
609−instance ToJSON ButtonImages where
610− toJSON = toJSON . getButtonImages
611−
612−instance ToSchema ButtonImages where
613− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
614− declareSchemaBoundedEnumKeyMapping
615−
616−buttonImagesSchemaJSON :: Value
617−buttonImagesSchemaJSON = [aesonQQ|
618−{
619− "type": "object",
620− "properties":
621− {
622− "Neutral": { "type": "string" },
623− "Focus": { "type": "string" },
624− "Active": { "type": "string" },
625− "Hover": { "type": "string" },
626− "Disabled": { "type": "string" }
627− }
628−}
629−|]
630−
631−-- ========================================================================
632−-- SingleMaybeField (single field data with optional field)
633−-- ========================================================================
634−
635−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
636− deriving (Show, Generic)
637−
638−instance ToJSON SingleMaybeField
639−instance ToSchema SingleMaybeField
640−
641−singleMaybeFieldSchemaJSON :: Value
642−singleMaybeFieldSchemaJSON = [aesonQQ|
643−{
644− "type": "object",
645− "properties":
646− {
647− "singleMaybeField": { "type": "string" }
648− }
649−}
650−|]
651−
652−
653−-- ========================================================================
654−-- TimeOfDay
655−-- ========================================================================
656−data TimeOfDay
657− = Int
658− | Pico
659− deriving (Generic)
660−instance ToSchema TimeOfDay
661−instance ToParamSchema TimeOfDay
662−
663−
664−timeOfDaySchemaJSON :: Value
665−timeOfDaySchemaJSON = [aesonQQ|
666−{
667− "example": "12:33:15",
668− "type": "string",
669− "format": "hh:MM:ss"
670−}
671−|]
672−
673−timeOfDayParamSchemaJSON :: Value
674−timeOfDayParamSchemaJSON = [aesonQQ|
675−{
676− "type": "string",
677− "format": "hh:MM:ss"
678−}
679−|]
test/Data/Swagger/ParamSchemaSpec.hs+84−10
@@ -1,29 +1,22 @@
11{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE DataKinds #-}
32{-# LANGUAGE ScopedTypeVariables #-}
43{-# LANGUAGE TemplateHaskell #-}
54{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
75module Data.Swagger.ParamSchemaSpec where
86
97import Data.Aeson
10−import Data.Aeson.QQ.Simple
8+import Data.Aeson.QQ
119import Data.Char
1210import Data.Proxy
1311import GHC.Generics
1412
1513import Data.Swagger
16−import Data.Swagger.Internal (SwaggerKind(..))
1714
18−import Data.Swagger.CommonTestTypes
1915import SpecCommon
2016import Test.Hspec
21−import Data.Time.LocalTime
22−
23−import qualified Data.HashMap.Strict as HM
2417
2518checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
19+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js
2720
2821spec :: Spec
2922spec = do
@@ -34,7 +27,88 @@ spec = do
3427 context "Unary records" $ do
3528 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
3629 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
3830
3931main :: IO ()
4032main = hspec spec
33+
34+-- ========================================================================
35+-- Unit type
36+-- ========================================================================
37+
38+data Unit = Unit deriving (Generic)
39+instance ToParamSchema Unit
40+
41+unitSchemaJSON :: Value
42+unitSchemaJSON = [aesonQQ|
43+{
44+ "type": "string",
45+ "enum": ["Unit"]
46+}
47+|]
48+
49+-- ========================================================================
50+-- Color (enum)
51+-- ========================================================================
52+data Color
53+ = Red
54+ | Green
55+ | Blue
56+ deriving (Generic)
57+instance ToParamSchema Color
58+
59+colorSchemaJSON :: Value
60+colorSchemaJSON = [aesonQQ|
61+{
62+ "type": "string",
63+ "enum": ["Red", "Green", "Blue"]
64+}
65+|]
66+
67+-- ========================================================================
68+-- Status (constructorTagModifier)
69+-- ========================================================================
70+
71+data Status = StatusOk | StatusError deriving (Generic)
72+
73+instance ToParamSchema Status where
74+ toParamSchema = genericToParamSchema defaultSchemaOptions
75+ { constructorTagModifier = map toLower . drop (length "Status") }
76+
77+statusSchemaJSON :: Value
78+statusSchemaJSON = [aesonQQ|
79+{
80+ "type": "string",
81+ "enum": ["ok", "error"]
82+}
83+|]
84+
85+-- ========================================================================
86+-- Email (newtype with unwrapUnaryRecords set to True)
87+-- ========================================================================
88+
89+newtype Email = Email { getEmail :: String }
90+ deriving (Generic)
91+instance ToParamSchema Email
92+
93+emailSchemaJSON :: Value
94+emailSchemaJSON = [aesonQQ|
95+{
96+ "type": "string"
97+}
98+|]
99+
100+-- ========================================================================
101+-- UserId (non-record newtype)
102+-- ========================================================================
103+
104+newtype UserId = UserId Integer
105+ deriving (Generic)
106+instance ToParamSchema UserId
107+
108+userIdSchemaJSON :: Value
109+userIdSchemaJSON = [aesonQQ|
110+{
111+ "type": "integer"
112+}
113+|]
114+
test/Data/Swagger/Schema/GeneratorSpec.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE PackageImports #-}
4−module Data.Swagger.Schema.GeneratorSpec where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Data.Swagger
10−import Data.Swagger.Schema.Generator
11−
12−import Control.Lens.Operators
13−import Data.Aeson
14−import Data.Hashable (Hashable)
15−import Data.HashMap.Strict (HashMap)
16−import qualified Data.HashMap.Strict as HashMap
17−import "unordered-containers" Data.HashSet (HashSet)
18−import qualified "unordered-containers" Data.HashSet as HashSet
19−import Data.Int
20−import Data.IntMap (IntMap)
21−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
22−import Data.Map (Map, fromList)
23−import Data.Monoid (mempty)
24−import Data.Proxy
25−import Data.Proxy
26−import Data.Set (Set)
27−import qualified Data.Text as T
28−import qualified Data.Text.Lazy as TL
29−import Data.Time
30−import Data.Version (Version)
31−import Data.Word
32−import GHC.Generics
33−
34−import Test.Hspec
35−import Test.Hspec.QuickCheck
36−import Test.QuickCheck
37−
38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
39−shouldValidate = validateFromJSON
40−
41−
42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
43−shouldNotValidate = expectFailure . shouldValidate
44−
45−
46−spec :: Spec
47−spec = do
48− describe "FromJSON validation" $ do
49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
64− prop "String" $ shouldValidate (Proxy :: Proxy String)
65− prop "()" $ shouldValidate (Proxy :: Proxy ())
66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
74− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
82− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
83− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
84− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
85− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
86− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
87− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
88− describe "Invalid FromJSON validation" $ do
89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
93−
94−-- =============================
95−-- Data types and bunk instances
96−-- =============================
97−
98−data WrongType = WrongType Bool
99−
100−instance FromJSON WrongType where
101− parseJSON = withBool "WrongType" $ return . WrongType
102−
103−instance ToSchema WrongType where
104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105− mempty
106− & type_ ?~ SwaggerObject
107−
108−
109−data MissingRequired = MissingRequired
110− { propA :: String
111− , propB :: Bool
112− }
113−
114−instance FromJSON MissingRequired where
115− parseJSON = withObject "MissingRequired" $ \o ->
116− MissingRequired
117− <$> o .: "propA"
118− <*> o .: "propB"
119−
120−instance ToSchema MissingRequired where
121− declareNamedSchema _ = do
122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124− return . NamedSchema (Just "MissingRequired") $
125− mempty
126− & type_ ?~ SwaggerObject
127− & properties .~ [("propA", stringSchema)
128− ,("propB", boolSchema)
129− ]
130− & required .~ ["propA"]
131−
132−data MissingProperty = MissingProperty
133− { propC :: String
134− , propD :: Bool
135− }
136−
137−instance FromJSON MissingProperty where
138− parseJSON = withObject "MissingProperty" $ \o ->
139− MissingProperty
140− <$> o .: "propC"
141− <*> o .: "propD"
142−
143−instance ToSchema MissingProperty where
144− declareNamedSchema _ = do
145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146− return . NamedSchema (Just "MissingProperty") $
147− mempty
148− & type_ ?~ SwaggerObject
149− & properties .~ [("propC", stringSchema)]
150− & required .~ ["propC"]
151−
152−data WrongPropType = WrongPropType
153− { propE :: String
154− }
155−
156−instance FromJSON WrongPropType where
157− parseJSON = withObject "WrongPropType" $ \o ->
158− WrongPropType
159− <$> o .: "propE"
160−
161−instance ToSchema WrongPropType where
162− declareNamedSchema _ = do
163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164− return . NamedSchema (Just "WrongPropType") $
165− mempty
166− & type_ ?~ SwaggerObject
167− & properties .~ [("propE", boolSchema)]
168− & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hs+65−130
@@ -1,50 +1,43 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE PackageImports #-}
74module Data.Swagger.Schema.ValidationSpec where
85
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)
6+import Control.Applicative
7+import Data.Aeson
8+import Data.Aeson.Types
9+import Data.Int
10+import Data.IntMap (IntMap)
11+import qualified Data.IntMap as IntMap
12+import Data.IntSet (IntSet)
13+import Data.Hashable (Hashable)
14+import "unordered-containers" Data.HashSet (HashSet)
1715import 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 ()
16+import Data.HashMap.Strict (HashMap)
17+import qualified Data.HashMap.Strict as HashMap
18+import Data.Map (Map)
19+import qualified Data.Map as Map
20+import Data.Proxy
21+import Data.Time
22+import qualified Data.Text as T
23+import qualified Data.Text.Lazy as TL
24+import Data.Set (Set)
25+import qualified Data.Set as Set
26+import Data.Word
27+import GHC.Generics
28+
29+import Data.Swagger
30+import Data.Swagger.Declare
31+import Data.Swagger.Schema.Validation
32+
33+import SpecCommon
34+import Test.Hspec
35+import Test.Hspec.QuickCheck
36+import Test.QuickCheck
3937
4038shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
4139shouldValidate _ x = validateToJSON x == []
4240
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−
4841spec :: Spec
4942spec = do
5043 describe "Validation" $ do
@@ -73,7 +66,6 @@ spec = do
7366 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
7467 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
7568 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
7769 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
7870 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
7971 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
@@ -83,7 +75,6 @@ spec = do
8375 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
8476 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
8577 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
8778 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
8879 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
8980 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
@@ -92,16 +83,6 @@ spec = do
9283 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
9384 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
9485 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
10586
10687main :: IO ()
10788main = hspec spec
@@ -121,13 +102,6 @@ instance ToSchema Person
121102instance Arbitrary Person where
122103 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
123104
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−
131105-- ========================================================================
132106-- Color (enum)
133107-- ========================================================================
@@ -139,11 +113,6 @@ instance ToSchema Color
139113instance Arbitrary Color where
140114 arbitrary = arbitraryBoundedEnum
141115
142−invalidColorToJSON :: Color -> Value
143−invalidColorToJSON Red = toJSON "red"
144−invalidColorToJSON Green = toJSON "green"
145−invalidColorToJSON Blue = toJSON "blue"
146−
147116-- ========================================================================
148117-- Paint (record with bounded enum property)
149118-- ========================================================================
@@ -157,9 +126,6 @@ instance ToSchema Paint
157126instance Arbitrary Paint where
158127 arbitrary = Paint <$> arbitrary
159128
160−invalidPaintToJSON :: Paint -> Value
161−invalidPaintToJSON = toJSON . color
162−
163129-- ========================================================================
164130-- MyRoseTree (custom datatypeNameModifier)
165131-- ========================================================================
@@ -188,8 +154,7 @@ instance Arbitrary MyRoseTree where
188154
189155data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
190156
191−instance ToSchema Light where
192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
157+instance ToSchema Light
193158
194159instance ToJSON Light where
195160 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
@@ -201,78 +166,48 @@ instance Arbitrary Light where
201166 , LightColor <$> arbitrary
202167 ]
203168
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
169+-- Arbitrary instances for common types
222170
223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
224− deriving (Show, Generic)
171+#if MIN_VERSION_QuickCheck(2,8,2)
172+#else
173+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where
174+ arbitrary = Map.fromList <$> arbitrary
225175
226−instance ToJSON ButtonImages where
227− toJSON = toJSON . getButtonImages
176+instance Arbitrary a => Arbitrary (IntMap a) where
177+ arbitrary = IntMap.fromList <$> arbitrary
228178
229−instance ToSchema ButtonImages where
230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
231− declareSchemaBoundedEnumKeyMapping
179+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where
180+ arbitrary = Set.fromList <$> arbitrary
181+#endif
232182
233−invalidButtonImagesToJSON :: ButtonImages -> Value
234−invalidButtonImagesToJSON = genericToJSON defaultOptions
183+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
184+ arbitrary = HashMap.fromList <$> arbitrary
235185
236−instance Arbitrary ButtonImages where
237− arbitrary = ButtonImages <$> arbitrary
186+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where
187+ arbitrary = HashSet.fromList <$> arbitrary
238188
239−-- ========================================================================
240−-- FreeForm (wraps a raw JSON Value)
241−-- ========================================================================
189+instance Arbitrary T.Text where
190+ arbitrary = T.pack <$> arbitrary
242191
243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
244− deriving (Show, Generic)
192+instance Arbitrary TL.Text where
193+ arbitrary = TL.pack <$> arbitrary
245194
246−instance ToJSON FreeForm where
247− toJSON = toJSON . jsonContent
195+instance Arbitrary Day where
196+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary
248197
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)
198+instance Arbitrary LocalTime where
199+ arbitrary = LocalTime
200+ <$> arbitrary
201+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))
261202
262203instance Eq ZonedTime where
263204 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
264205
265−-- ========================================================================
266−-- Arbitrary instance for Data.Aeson.Value
267−-- ========================================================================
206+instance Arbitrary ZonedTime where
207+ arbitrary = ZonedTime
208+ <$> arbitrary
209+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))
210+
211+instance Arbitrary UTCTime where
212+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
268213
269−instance Arbitrary Value where
270− -- Weights are almost random
271− -- Uniform oneof tends not to build complex objects cause of recursive call.
272− arbitrary = resize 4 $ frequency
273− [ (3, Object <$> arbitrary)
274− , (3, Array <$> arbitrary)
275− , (3, String <$> arbitrary)
276− , (3, Number <$> arbitrary)
277− , (3, Bool <$> arbitrary)
278− , (1, return Null) ]
test/Data/Swagger/SchemaSpec.hs+513−25
@@ -7,23 +7,22 @@ module Data.Swagger.SchemaSpec where
77import Prelude ()
88import Prelude.Compat
99
10−import Control.Lens ((^.))
11−import Data.Aeson (Value)
12−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
10+import Data.Aeson
11+import Data.Aeson.QQ
12+import Data.Char
13+import qualified Data.HashMap.Strict as HashMap
1314import Data.Proxy
1415import Data.Set (Set)
16+import qualified Data.Set as Set
1517import qualified Data.Text as Text
18+import GHC.Generics
1619
1720import Data.Swagger
1821import Data.Swagger.Declare
1922
20−import Data.Swagger.CommonTestTypes
2123import SpecCommon
2224import Test.Hspec
2325
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
2726checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
2827checkToSchema proxy js = toSchema proxy <=> js
2928
@@ -35,17 +34,10 @@ checkSchemaName sname proxy =
3534checkDefs :: ToSchema a => Proxy a -> [String] -> Spec
3635checkDefs proxy names =
3736 it ("uses these definitions " ++ show names) $
38− InsOrdHashMap.keys defs `shouldBe` map Text.pack names
37+ Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)
3938 where
4039 defs = execDeclare (declareNamedSchema proxy) mempty
4140
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−
4941checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec
5042checkInlinedSchema proxy js = toInlinedSchema proxy <=> js
5143
@@ -66,9 +58,6 @@ spec = do
6658 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON
6759 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON
6860 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
7261 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON
7362 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON
7463 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON
@@ -77,10 +66,8 @@ spec = do
7766 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
7867 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
7968 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
8169 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
8270 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
8471 context "Sum types" $ do
8572 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
8673 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -96,7 +83,6 @@ spec = do
9683 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
9784 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
9885 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
10086 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
10187 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
10288 describe "Inlining Schemas" $ do
@@ -105,10 +91,512 @@ spec = do
10591 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
10692 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
10793 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
11294
11395main :: IO ()
11496main = hspec spec
97+
98+-- ========================================================================
99+-- Person (simple record with optional fields)
100+-- ========================================================================
101+data Person = Person
102+ { name :: String
103+ , phone :: Integer
104+ , email :: Maybe String
105+ } deriving (Generic)
106+
107+instance ToSchema Person
108+
109+personSchemaJSON :: Value
110+personSchemaJSON = [aesonQQ|
111+{
112+ "type": "object",
113+ "properties":
114+ {
115+ "name": { "type": "string" },
116+ "phone": { "type": "integer" },
117+ "email": { "type": "string" }
118+ },
119+ "required": ["name", "phone"]
120+}
121+|]
122+
123+-- ========================================================================
124+-- ISPair (non-record product data type)
125+-- ========================================================================
126+data ISPair = ISPair Integer String
127+ deriving (Generic)
128+
129+instance ToSchema ISPair
130+
131+ispairSchemaJSON :: Value
132+ispairSchemaJSON = [aesonQQ|
133+{
134+ "type": "array",
135+ "items":
136+ [
137+ { "type": "integer" },
138+ { "type": "string" }
139+ ]
140+}
141+|]
142+
143+-- ========================================================================
144+-- Point (record data type with custom fieldLabelModifier)
145+-- ========================================================================
146+data Point = Point
147+ { pointX :: Double
148+ , pointY :: Double
149+ } deriving (Generic)
150+
151+instance ToSchema Point where
152+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
153+ { fieldLabelModifier = map toLower . drop (length "point") }
154+
155+pointSchemaJSON :: Value
156+pointSchemaJSON = [aesonQQ|
157+{
158+ "type": "object",
159+ "properties":
160+ {
161+ "x": { "type": "number", "format": "double" },
162+ "y": { "type": "number", "format": "double" }
163+ },
164+ "required": ["x", "y"]
165+}
166+|]
167+
168+
169+-- ========================================================================
170+-- Color (enum)
171+-- ========================================================================
172+data Color
173+ = Red
174+ | Green
175+ | Blue
176+ deriving (Generic)
177+instance ToSchema Color
178+
179+colorSchemaJSON :: Value
180+colorSchemaJSON = [aesonQQ|
181+{
182+ "type": "string",
183+ "enum": ["Red", "Green", "Blue"]
184+}
185+|]
186+
187+-- ========================================================================
188+-- Shade (paramSchemaToNamedSchema)
189+-- ========================================================================
190+
191+data Shade = Dim | Bright deriving (Generic)
192+instance ToParamSchema Shade
193+
194+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
195+
196+shadeSchemaJSON :: Value
197+shadeSchemaJSON = [aesonQQ|
198+{
199+ "type": "string",
200+ "enum": ["Dim", "Bright"]
201+}
202+|]
203+
204+-- ========================================================================
205+-- Paint (record with bounded enum property)
206+-- ========================================================================
207+
208+newtype Paint = Paint { color :: Color }
209+ deriving (Generic)
210+instance ToSchema Paint
211+
212+paintSchemaJSON :: Value
213+paintSchemaJSON = [aesonQQ|
214+{
215+ "type": "object",
216+ "properties":
217+ {
218+ "color":
219+ {
220+ "$ref": "#/definitions/Color"
221+ }
222+ },
223+ "required": ["color"]
224+}
225+|]
226+
227+paintInlinedSchemaJSON :: Value
228+paintInlinedSchemaJSON = [aesonQQ|
229+{
230+ "type": "object",
231+ "properties":
232+ {
233+ "color":
234+ {
235+ "type": "string",
236+ "enum": ["Red", "Green", "Blue"]
237+ }
238+ },
239+ "required": ["color"]
240+}
241+|]
242+
243+-- ========================================================================
244+-- Email (newtype with unwrapUnaryRecords set to True)
245+-- ========================================================================
246+
247+newtype Email = Email { getEmail :: String }
248+ deriving (Generic)
249+
250+instance ToSchema Email where
251+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
252+ { unwrapUnaryRecords = True }
253+
254+emailSchemaJSON :: Value
255+emailSchemaJSON = [aesonQQ|
256+{
257+ "type": "string"
258+}
259+|]
260+
261+-- ========================================================================
262+-- UserId (non-record newtype)
263+-- ========================================================================
264+
265+newtype UserId = UserId Integer
266+ deriving (Eq, Ord, Generic)
267+instance ToSchema UserId
268+
269+userIdSchemaJSON :: Value
270+userIdSchemaJSON = [aesonQQ|
271+{
272+ "type": "integer"
273+}
274+|]
275+
276+-- ========================================================================
277+-- UserGroup (set newtype)
278+-- ========================================================================
279+
280+newtype UserGroup = UserGroup (Set UserId)
281+ deriving (Generic)
282+instance ToSchema UserGroup
283+
284+userGroupSchemaJSON :: Value
285+userGroupSchemaJSON = [aesonQQ|
286+{
287+ "type": "array",
288+ "items": { "$ref": "#/definitions/UserId" },
289+ "uniqueItems": true
290+}
291+|]
292+
293+-- ========================================================================
294+-- Player (record newtype)
295+-- ========================================================================
296+
297+newtype Player = Player
298+ { position :: Point
299+ } deriving (Generic)
300+instance ToSchema Player
301+
302+playerSchemaJSON :: Value
303+playerSchemaJSON = [aesonQQ|
304+{
305+ "type": "object",
306+ "properties":
307+ {
308+ "position":
309+ {
310+ "$ref": "#/definitions/Point"
311+ }
312+ },
313+ "required": ["position"]
314+}
315+|]
316+
317+-- ========================================================================
318+-- MyRoseTree (custom datatypeNameModifier)
319+-- ========================================================================
320+
321+data MyRoseTree = MyRoseTree
322+ { root :: String
323+ , trees :: [MyRoseTree]
324+ } deriving (Generic)
325+
326+instance ToSchema MyRoseTree where
327+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
328+ { datatypeNameModifier = drop (length "My") }
329+
330+myRoseTreeSchemaJSON :: Value
331+myRoseTreeSchemaJSON = [aesonQQ|
332+{
333+ "type": "object",
334+ "properties":
335+ {
336+ "root": { "type": "string" },
337+ "trees":
338+ {
339+ "type": "array",
340+ "items":
341+ {
342+ "$ref": "#/definitions/RoseTree"
343+ }
344+ }
345+ },
346+ "required": ["root", "trees"]
347+}
348+|]
349+
350+-- ========================================================================
351+-- Inlined (newtype for inlining schemas)
352+-- ========================================================================
353+
354+newtype Inlined a = Inlined { getInlined :: a }
355+
356+instance ToSchema a => ToSchema (Inlined a) where
357+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
358+ where
359+ unname (NamedSchema _ s) = NamedSchema Nothing s
360+
361+newtype Players = Players [Inlined Player]
362+ deriving (Generic)
363+instance ToSchema Players
364+
365+playersSchemaJSON :: Value
366+playersSchemaJSON = [aesonQQ|
367+{
368+ "type": "array",
369+ "items":
370+ {
371+ "type": "object",
372+ "properties":
373+ {
374+ "position":
375+ {
376+ "$ref": "#/definitions/Point"
377+ }
378+ },
379+ "required": ["position"]
380+ }
381+}
382+|]
383+
384+-- ========================================================================
385+-- Status (sum type with unary constructors)
386+-- ========================================================================
387+
388+data Status
389+ = StatusOk String
390+ | StatusError String
391+ deriving (Generic)
392+
393+instance ToSchema Status where
394+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
395+ { constructorTagModifier = map toLower . drop (length "Status") }
396+
397+statusSchemaJSON :: Value
398+statusSchemaJSON = [aesonQQ|
399+{
400+ "type": "object",
401+ "properties":
402+ {
403+ "ok": { "type": "string" },
404+ "error": { "type": "string" }
405+ },
406+ "maxProperties": 1,
407+ "minProperties": 1
408+}
409+|]
410+
411+-- ========================================================================
412+-- Unit type
413+-- ========================================================================
414+
415+data Unit = Unit deriving (Generic)
416+instance ToSchema Unit
417+
418+unitSchemaJSON :: Value
419+unitSchemaJSON = [aesonQQ|
420+{
421+ "type": "string",
422+ "enum": ["Unit"]
423+}
424+|]
425+
426+
427+-- ========================================================================
428+-- Character (sum type with ref and record in alternative)
429+-- ========================================================================
430+
431+data Character
432+ = PC Player
433+ | NPC { npcName :: String, npcPosition :: Point }
434+ deriving (Generic)
435+instance ToSchema Character
436+
437+characterSchemaJSON :: Value
438+characterSchemaJSON = [aesonQQ|
439+{
440+ "type": "object",
441+ "properties":
442+ {
443+ "PC": { "$ref": "#/definitions/Player" },
444+ "NPC":
445+ {
446+ "type": "object",
447+ "properties":
448+ {
449+ "npcName": { "type": "string" },
450+ "npcPosition": { "$ref": "#/definitions/Point" }
451+ },
452+ "required": ["npcName", "npcPosition"]
453+ }
454+ },
455+ "maxProperties": 1,
456+ "minProperties": 1
457+}
458+|]
459+
460+characterInlinedSchemaJSON :: Value
461+characterInlinedSchemaJSON = [aesonQQ|
462+{
463+ "type": "object",
464+ "properties":
465+ {
466+ "PC":
467+ {
468+ "type": "object",
469+ "properties":
470+ {
471+ "position":
472+ {
473+ "type": "object",
474+ "properties":
475+ {
476+ "x": { "type": "number", "format": "double" },
477+ "y": { "type": "number", "format": "double" }
478+ },
479+ "required": ["x", "y"]
480+ }
481+ },
482+ "required": ["position"]
483+ },
484+ "NPC":
485+ {
486+ "type": "object",
487+ "properties":
488+ {
489+ "npcName": { "type": "string" },
490+ "npcPosition":
491+ {
492+ "type": "object",
493+ "properties":
494+ {
495+ "x": { "type": "number", "format": "double" },
496+ "y": { "type": "number", "format": "double" }
497+ },
498+ "required": ["x", "y"]
499+ }
500+ },
501+ "required": ["npcName", "npcPosition"]
502+ }
503+ },
504+ "maxProperties": 1,
505+ "minProperties": 1
506+}
507+|]
508+
509+characterInlinedPlayerSchemaJSON :: Value
510+characterInlinedPlayerSchemaJSON = [aesonQQ|
511+{
512+ "type": "object",
513+ "properties":
514+ {
515+ "PC":
516+ {
517+ "type": "object",
518+ "properties":
519+ {
520+ "position":
521+ {
522+ "$ref": "#/definitions/Point"
523+ }
524+ },
525+ "required": ["position"]
526+ },
527+ "NPC":
528+ {
529+ "type": "object",
530+ "properties":
531+ {
532+ "npcName": { "type": "string" },
533+ "npcPosition": { "$ref": "#/definitions/Point" }
534+ },
535+ "required": ["npcName", "npcPosition"]
536+ }
537+ },
538+ "maxProperties": 1,
539+ "minProperties": 1
540+}
541+|]
542+
543+-- ========================================================================
544+-- Light (sum type with unwrapUnaryRecords)
545+-- ========================================================================
546+
547+data Light
548+ = NoLight
549+ | LightFreq Double
550+ | LightColor Color
551+ | LightWaveLength { waveLength :: Double }
552+ deriving (Generic)
553+
554+instance ToSchema Light where
555+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
556+ { unwrapUnaryRecords = True }
557+
558+lightSchemaJSON :: Value
559+lightSchemaJSON = [aesonQQ|
560+{
561+ "type": "object",
562+ "properties":
563+ {
564+ "NoLight": { "type": "array", "items": [] },
565+ "LightFreq": { "type": "number", "format": "double" },
566+ "LightColor": { "$ref": "#/definitions/Color" },
567+ "LightWaveLength": { "type": "number", "format": "double" }
568+ },
569+ "maxProperties": 1,
570+ "minProperties": 1
571+}
572+|]
573+
574+lightInlinedSchemaJSON :: Value
575+lightInlinedSchemaJSON = [aesonQQ|
576+{
577+ "type": "object",
578+ "properties":
579+ {
580+ "NoLight": { "type": "array", "items": [] },
581+ "LightFreq": { "type": "number", "format": "double" },
582+ "LightColor":
583+ {
584+ "type": "string",
585+ "enum": ["Red", "Green", "Blue"]
586+ },
587+ "LightWaveLength": { "type": "number", "format": "double" }
588+ },
589+ "maxProperties": 1,
590+ "minProperties": 1
591+}
592+|]
593+
594+-- ========================================================================
595+-- ResourceId (series of newtypes)
596+-- ========================================================================
597+
598+newtype Id = Id String deriving (Generic)
599+instance ToSchema Id
600+
601+newtype ResourceId = ResourceId Id deriving (Generic)
602+instance ToSchema ResourceId
test/Data/SwaggerSpec.hs+28−114
@@ -10,9 +10,9 @@ import Prelude.Compat
1010import Control.Lens
1111
1212import Data.Aeson
13−import Data.Aeson.QQ.Simple
13+import Data.Aeson.QQ
1414import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
15+import qualified Data.Set as Set
1616import Data.Text (Text)
1717
1818import Data.Swagger
@@ -37,14 +37,11 @@ spec = do
3737 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
3838 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
3939 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
4140 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
4241 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
4342 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
4443 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
4544 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
4845 describe "Swagger Object" $ do
4946 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
5047 context "PetStore Example" $
@@ -128,7 +125,7 @@ licenseExampleJSON = [aesonQQ|
128125
129126operationExample :: Operation
130127operationExample = mempty
131− & tags .~ InsOrdHS.fromList ["pet"]
128+ & tags .~ Set.fromList ["pet"]
132129 & summary ?~ "Updates a pet in the store with form data"
133130 & description ?~ ""
134131 & operationId ?~ "updatePetWithForm"
@@ -159,7 +156,7 @@ operationExample = mempty
159156 stringSchema :: ParamLocation -> ParamOtherSchema
160157 stringSchema loc = mempty
161158 & in_ .~ loc
162− & type_ ?~ SwaggerString
159+ & type_ .~ SwaggerString
163160
164161operationExampleJSON :: Value
165162operationExampleJSON = [aesonQQ|
@@ -225,7 +222,7 @@ operationExampleJSON = [aesonQQ|
225222
226223schemaPrimitiveExample :: Schema
227224schemaPrimitiveExample = mempty
228− & type_ ?~ SwaggerString
225+ & type_ .~ SwaggerString
229226 & format ?~ "email"
230227
231228schemaPrimitiveExampleJSON :: Value
@@ -238,14 +235,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
238235
239236schemaSimpleModelExample :: Schema
240237schemaSimpleModelExample = mempty
241− & type_ ?~ SwaggerObject
238+ & type_ .~ SwaggerObject
242239 & required .~ [ "name" ]
243240 & properties .~
244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
241+ [ ("name", Inline (mempty & type_ .~ SwaggerString))
245242 , ("address", Ref (Reference "Address"))
246243 , ("age", Inline $ mempty
247244 & minimum_ ?~ 0
248− & type_ ?~ SwaggerInteger
245+ & type_ .~ SwaggerInteger
249246 & format ?~ "int32" ) ]
250247
251248schemaSimpleModelExampleJSON :: Value
@@ -273,8 +270,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
273270
274271schemaModelDictExample :: Schema
275272schemaModelDictExample = mempty
276− & type_ ?~ SwaggerObject
277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
273+ & type_ .~ SwaggerObject
274+ & additionalProperties ?~ (mempty & type_ .~ SwaggerString)
278275
279276schemaModelDictExampleJSON :: Value
280277schemaModelDictExampleJSON = [aesonQQ|
@@ -286,28 +283,15 @@ schemaModelDictExampleJSON = [aesonQQ|
286283}
287284|]
288285
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−
302286schemaWithExampleExample :: Schema
303287schemaWithExampleExample = mempty
304− & type_ ?~ SwaggerObject
288+ & type_ .~ SwaggerObject
305289 & properties .~
306290 [ ("id", Inline $ mempty
307− & type_ ?~ SwaggerInteger
291+ & type_ .~ SwaggerInteger
308292 & format ?~ "int64" )
309293 , ("name", Inline $ mempty
310− & type_ ?~ SwaggerString) ]
294+ & type_ .~ SwaggerString) ]
311295 & required .~ [ "name" ]
312296 & example ?~ [aesonQQ|
313297 {
@@ -346,19 +330,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
346330definitionsExample :: HashMap Text Schema
347331definitionsExample =
348332 [ ("Category", mempty
349− & type_ ?~ SwaggerObject
333+ & type_ .~ SwaggerObject
350334 & properties .~
351335 [ ("id", Inline $ mempty
352− & type_ ?~ SwaggerInteger
336+ & type_ .~ SwaggerInteger
353337 & format ?~ "int64")
354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
338+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
355339 , ("Tag", mempty
356− & type_ ?~ SwaggerObject
340+ & type_ .~ SwaggerObject
357341 & properties .~
358342 [ ("id", Inline $ mempty
359− & type_ ?~ SwaggerInteger
343+ & type_ .~ SwaggerInteger
360344 & format ?~ "int64")
361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
345+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
362346
363347definitionsExampleJSON :: Value
364348definitionsExampleJSON = [aesonQQ|
@@ -402,7 +386,7 @@ paramsDefinitionExample =
402386 & required ?~ True
403387 & schema .~ ParamOther (mempty
404388 & in_ .~ ParamQuery
405− & type_ ?~ SwaggerInteger
389+ & type_ .~ SwaggerInteger
406390 & format ?~ "int32" ))
407391 , ("limitParam", mempty
408392 & name .~ "limit"
@@ -410,7 +394,7 @@ paramsDefinitionExample =
410394 & required ?~ True
411395 & schema .~ ParamOther (mempty
412396 & in_ .~ ParamQuery
413− & type_ ?~ SwaggerInteger
397+ & type_ .~ SwaggerInteger
414398 & format ?~ "int32" )) ]
415399
416400paramsDefinitionExampleJSON :: Value
@@ -460,8 +444,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
460444-- Responses Definition object
461445-- =======================================================================
462446
463−securityDefinitionsExample :: SecurityDefinitions
464−securityDefinitionsExample = SecurityDefinitions
447+securityDefinitionsExample :: HashMap Text SecurityScheme
448+securityDefinitionsExample =
465449 [ ("api_key", SecurityScheme
466450 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
467451 , _securitySchemeDescription = Nothing })
@@ -493,46 +477,6 @@ securityDefinitionsExampleJSON = [aesonQQ|
493477}
494478|]
495479
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−
536480-- =======================================================================
537481-- Swagger object
538482-- =======================================================================
@@ -551,7 +495,7 @@ swaggerExample = mempty
551495 & at 200 ?~ Inline (mempty
552496 & description .~ "OK"
553497 & schema ?~ Inline (mempty
554− & type_ ?~ SwaggerObject
498+ & type_ .~ SwaggerObject
555499 & example ?~ [aesonQQ|
556500 {
557501 "created": 100,
@@ -560,9 +504,9 @@ swaggerExample = mempty
560504 & description ?~ "This is some real Todo right here"
561505 & properties .~
562506 [ ("created", Inline $ mempty
563− & type_ ?~ SwaggerInteger
507+ & type_ .~ SwaggerInteger
564508 & format ?~ "int32")
565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
509+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))
566510 & produces ?~ MimeList [ "application/json" ]
567511 & parameters .~
568512 [ Inline $ mempty
@@ -571,8 +515,8 @@ swaggerExample = mempty
571515 & description ?~ "TodoId param"
572516 & schema .~ ParamOther (mempty
573517 & in_ .~ ParamPath
574− & type_ ?~ SwaggerString ) ]
575− & tags .~ InsOrdHS.fromList [ "todo" ] ))
518+ & type_ .~ SwaggerString ) ]
519+ & tags .~ Set.fromList [ "todo" ] ))
576520
577521swaggerExampleJSON :: Value
578522swaggerExampleJSON = [aesonQQ|
@@ -1670,33 +1614,3 @@ petstoreExampleJSON = [aesonQQ|
16701614 }
16711615}
16721616|]
1673−
1674−compositionSchemaExample :: Schema
1675−compositionSchemaExample = mempty
1676− & type_ ?~ SwaggerObject
1677− & Data.Swagger.allOf ?~ [
1678− Ref (Reference "Other")
1679− , Inline (mempty
1680− & type_ ?~ SwaggerObject
1681− & properties .~
1682− [ ("greet", Inline $ mempty
1683− & type_ ?~ SwaggerString) ])
1684− ]
1685−
1686−compositionSchemaExampleJSON :: Value
1687−compositionSchemaExampleJSON = [aesonQQ|
1688−{
1689− "type": "object",
1690− "allOf": [
1691− {
1692− "$ref": "#/definitions/Other"
1693− },
1694− {
1695− "type": "object",
1696− "properties": {
1697− "greet": { "type": "string" }
1698− }
1699− }
1700− ]
1701−}
1702−|]
test/DocTest.hsnew file+8
@@ -0,0 +1,8 @@
1+module Main (main) where
2+
3+import System.FilePath.Glob (glob)
4+import Test.DocTest (doctest)
5+
6+main :: IO ()
7+main = glob "src/**/*.hs" >>= doctest'
8+ where doctest' files = doctest $ "-Iinclude/" : "-D__DOCTEST__" : files
test/SpecCommon.hs+2−7
@@ -1,7 +1,6 @@
11module SpecCommon where
22
33import Data.Aeson
4−import Data.ByteString.Builder (toLazyByteString)
54import qualified Data.Foldable as F
65import qualified Data.HashMap.Strict as HashMap
76import qualified Data.Vector as Vector
@@ -22,9 +21,5 @@ x <=> js = do
2221 toJSON x `shouldBe` js
2322 it "decodes correctly" $ do
2423 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
24+
25+
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