git.iko.soy/typeable/swagger2
on master help sign in
swap
5470313155 ahead, 0 behind
33 files changed+2913−1074
since splitsnapshots
unifiedsplit
.ghci+1 .travis.yml+140−81 CHANGELOG.md+104−4 LICENSE+1−1 aeson-0.11.cabal.config−1 cabal.project+2 examples/hackage.hs+1−1 hackage-docs.sh+78 src/Data/Swagger.hs+10−4 src/Data/Swagger/Declare.hs+4−5 src/Data/Swagger/Internal.hs+146−29 src/Data/Swagger/Internal/AesonUtils.hs+16−3 src/Data/Swagger/Internal/ParamSchema.hs+60−25 src/Data/Swagger/Internal/Schema.hs+159−68 src/Data/Swagger/Internal/Schema/Validation.hs+242−56 src/Data/Swagger/Internal/Utils.hs−1 src/Data/Swagger/Lens.hs+10−4 src/Data/Swagger/Operation.hs+5−5 src/Data/Swagger/Optics.hs+597 src/Data/Swagger/Schema.hs+11 src/Data/Swagger/Schema/Generator.hs+114 src/Data/Swagger/Schema/Validation.hs+10−1 src/Data/Swagger/SchemaOptions.hs+29 stack-ghc-8.0.yaml−5 stack-lts-2.yaml−22 stack.yaml+7−1 swagger2.cabal+84−48 test/Data/Swagger/CommonTestTypes.hs+679 test/Data/Swagger/ParamSchemaSpec.hs+7−83 test/Data/Swagger/Schema/GeneratorSpec.hs+168 test/Data/Swagger/Schema/ValidationSpec.hs+130−48 test/Data/Swagger/SchemaSpec.hs+12−547 test/Data/SwaggerSpec.hs+86−31
.ghci+1
@@ -1 +1,2 @@
11: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
.travis.yml+140−81
@@ -1,103 +1,162 @@
11# This Travis job script has been generated by a script via
22#
3−# make_travis_yml_2.hs '--branch' 'master' 'swagger2.cabal'
3+# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal'
44#
5−# For more information, see https://github.com/hvr/multi-ghc-travis
5+# For more information, see https://github.com/haskell-CI/haskell-ci
6+#
7+# version: 0.5.20191020
68#
79language: c
8−sudo: false
9−
10+dist: xenial
1011git:
11− submodules: false # whether to recursively clone submodules
12−
12+ # whether to recursively clone submodules
13+ submodules: false
1314branches:
1415 only:
1516 - master
16−
1717cache:
1818 directories:
1919 - $HOME/.cabal/packages
2020 - $HOME/.cabal/store
21−
2221before_cache:
23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
2423 # remove files that are regenerated by 'cabal update'
25− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
26− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
27− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
28− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
29− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
30−
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
3130matrix:
3231 include:
33− - compiler: "ghc-7.8.4"
34− # env: TEST=--disable-tests BENCH=--disable-benchmarks
35− env: HADDOCK=false
36− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}}
37− - compiler: "ghc-7.10.3"
38− # env: TEST=--disable-tests BENCH=--disable-benchmarks
39− env: HADDOCK=false
40− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}
41− - compiler: "ghc-8.0.2"
42− # env: TEST=--disable-tests BENCH=--disable-benchmarks
43− env: HADDOCK=false
44− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
45− - compiler: "ghc-8.2.1"
46− # env: TEST=--disable-tests BENCH=--disable-benchmarks
47− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
48−
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"]}}
4942before_install:
50− - HC=${CC}
51− - unset CC
52− - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
53− - PKGNAME='swagger2'
54−
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
5574install:
56− - cabal --version
57− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
58− - BENCH=${BENCH---enable-benchmarks}
59− - TEST=${TEST---enable-tests}
60− - HADDOCK=${HADDOCK-true}
61− - INSTALLED=${INSTALLED-true}
62− - travis_retry cabal update -v
63− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
64− - rm -fv cabal.project.local
65− - "echo 'packages: .' > cabal.project"
66− - rm -f cabal.project.freeze
67− - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all
68− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all
69−
70−# Here starts the actual work to be performed for the package under test;
71−# any command which exits with a non-zero exit code causes the build to fail.
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
72126script:
73− - if [ -f configure.ac ]; then autoreconf -i; fi
74− - rm -rf .ghc.environment.* dist/
75− - cabal sdist # test that a source-distribution can be generated
76− - cd dist/
77− - SRCTAR=(${PKGNAME}-*.tar.gz)
78− - SRC_BASENAME="${SRCTAR/%.tar.gz}"
79− - tar -xvf "./$SRC_BASENAME.tar.gz"
80− - cd "$SRC_BASENAME/"
81−## from here on, CWD is inside the extracted source-tarball
82− - rm -fv cabal.project.local
83− - "echo 'packages: .' > cabal.project"
84− # this builds all libraries and executables (without tests/benchmarks)
85− - rm -f cabal.project.freeze
86− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
87− # this builds all libraries and executables (including tests/benchmarks)
88− # - rm -rf ./dist-newstyle
89−
90− # Build with installed constraints for packages in global-db
91− - if $INSTALLED; then
92− ghc-pkg list --simple-output --names-only | sed -r 's/([a-zA-Z0-9-]+*) */--constraint=\1 installed;/g' | sed 's/;$/;all/' | xargs -d ';' cabal new-build -w ${HC} --disable-tests --disable-benchmarks;
93− else echo "Not building with installed constraints"; fi
94−
95− # build & run tests, build benchmarks
96− - cabal new-build -w ${HC} ${TEST} ${BENCH} all
97− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
98−
99− # haddock
100− - rm -rf ./dist-newstyle
101− - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
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
102160
161+# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
103162# EOF
CHANGELOG.md+104−4
@@ -1,13 +1,113 @@
1−2.1.4.2
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
227-------
328
4−* `allOf` accepts reference schema (see [#119](https://github.com/GetShopTV/swagger2/issues/119))
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)).
5103
61042.1.4.1
7105-------
8106
9−* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95))
10−* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105))
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)).
11111
121122.1.4
13113-----
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2016, GetShopTV
1+Copyright (c) 2015-2017, GetShopTV
22All rights reserved.
33
44Redistribution and use in source and binary forms, with or without
aeson-0.11.cabal.configdeleted−1
@@ -1 +0,0 @@
1−constraints: aeson ==0.11.*
cabal.projectnew file+2
@@ -0,0 +1,2 @@
1+packages: .
2+tests: true
examples/hackage.hs+1−1
@@ -27,7 +27,7 @@ instance ToSchema UserSummary where
2727 usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
2828 useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
2929 return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ .~ SwaggerObject
30+ & type_ ?~ SwaggerObject
3131 & properties .~
3232 [ ("summaryUsername", usernameSchema )
3333 , ("summaryUserid" , useridSchema )
hackage-docs.shnew file+78
@@ -0,0 +1,78 @@
1+#!/bin/bash
2+set -e
3+
4+# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5+
6+if [ "$#" -ne 1 ]; then
7+ echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8+ exit 1
9+fi
10+
11+user=$1
12+
13+cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14+if [ ! -f "$cabal_file" ]; then
15+ echo "Run this script in the top-level package directory"
16+ exit 1
17+fi
18+
19+pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20+ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21+
22+if [ -z "$pkg" ]; then
23+ echo "Unable to determine package name"
24+ exit 1
25+fi
26+
27+if [ -z "$ver" ]; then
28+ echo "Unable to determine package version"
29+ exit 1
30+fi
31+
32+echo "Detected package: $pkg-$ver"
33+
34+dir=$(mktemp -d build-docs.XXXXXX)
35+trap 'rm -r "$dir"' EXIT
36+
37+export PATH=$(stack path --bin-path)
38+
39+ghc --version
40+cabal --version
41+stack --version
42+
43+if haddock --hyperlinked-source >/dev/null
44+then
45+ echo "Using fancy hyperlinked source"
46+ HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47+else
48+ echo "Using boring hyperlinked source"
49+ HYPERLINK_FLAG="--hyperlink-source"
50+fi
51+
52+# Cabal dist in temporary location
53+builddir=$dir/dist
54+
55+# Build dependencies haddocks with stack, so we get links
56+stack haddock --only-dependencies
57+
58+# Configure using stack databases
59+snapshotpkgdb=$(stack path --snapshot-pkg-db)
60+localpkgdb=$(stack path --local-pkg-db)
61+cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62+
63+# Build Hadckage compatible docs
64+cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65+
66+# Copy into right directory
67+cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68+
69+# Tar and gzip
70+tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71+
72+# Upload
73+curl -X PUT \
74+ -H 'Content-Type: application/x-tar' \
75+ -H 'Content-Encoding: gzip' \
76+ -u "$user" \
77+ --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78+ "https://hackage.haskell.org/package/$pkg-$ver/docs"
src/Data/Swagger.hs+10−4
@@ -31,6 +31,7 @@ module Data.Swagger (
3131
3232 -- * Re-exports
3333 module Data.Swagger.Lens,
34+ module Data.Swagger.Optics,
3435 module Data.Swagger.Operation,
3536 module Data.Swagger.ParamSchema,
3637 module Data.Swagger.Schema,
@@ -77,6 +78,7 @@ module Data.Swagger (
7778 SwaggerItems(..),
7879 Xml(..),
7980 Pattern,
81+ AdditionalProperties(..),
8082
8183 -- ** Responses
8284 Responses(..),
@@ -87,6 +89,7 @@ module Data.Swagger (
8789 SecurityScheme(..),
8890 SecuritySchemeType(..),
8991 SecurityRequirement(..),
92+ SecurityDefinitions(..),
9093
9194 -- *** API key
9295 ApiKeyParams(..),
@@ -111,6 +114,7 @@ module Data.Swagger (
111114) where
112115
113116import Data.Swagger.Lens
117+import Data.Swagger.Optics ()
114118import Data.Swagger.Operation
115119import Data.Swagger.ParamSchema
116120import Data.Swagger.Schema
@@ -174,13 +178,15 @@ import Data.Swagger.Internal
174178
175179-- $lens
176180--
181+-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182+--
177183-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
178184-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
179185-- make it fairly simple to construct/modify any part of the specification:
180186--
181187-- >>> :{
182188-- encode $ (mempty :: Swagger)
183−-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
189+-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
184190-- & paths .~
185191-- [ ("/user", mempty & get ?~ (mempty
186192-- & produces ?~ MimeList ["application/json"]
@@ -203,7 +209,7 @@ import Data.Swagger.Internal
203209-- "{\"description\":\"No content\"}"
204210-- >>> :{
205211-- encode $ (mempty :: Schema)
206−-- & type_ .~ SwaggerBoolean
212+-- & type_ ?~ SwaggerBoolean
207213-- & description ?~ "To be or not to be"
208214-- :}
209215-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
@@ -212,7 +218,7 @@ import Data.Swagger.Internal
212218-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
213219-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
214220--
215−-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
221+-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
216222-- "{\"type\":\"number\"}"
217223--
218224-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
@@ -274,7 +280,7 @@ import Data.Swagger.Internal
274280-- >>> encode $ toSchema (Proxy :: Proxy Person)
275281-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
276282--
277−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
283+-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
278284-- schema for basic enums like
279285--
280286-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
src/Data/Swagger/Declare.hs+4−5
@@ -29,7 +29,6 @@ import Control.Monad.Trans.RWS.Strict as Strict
2929import Control.Monad.Trans.Writer.Lazy as Lazy
3030import Control.Monad.Trans.Writer.Strict as Strict
3131import Data.Functor.Identity
32−import Data.Monoid
3332
3433-- | A declare monad transformer parametrized by:
3534--
@@ -50,15 +49,15 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
5049 pure x = DeclareT (\_ -> pure (mempty, x))
5150 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
5251 ~(d', f) <- df d
53− ~(d'', x) <- dx (d <> d')
54− return (d' <> d'', f x)
52+ ~(d'', x) <- dx (mappend d d')
53+ return (mappend d' d'', f x)
5554
5655instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
5756 return x = DeclareT (\_ -> pure (mempty, x))
5857 DeclareT dx >>= f = DeclareT $ \d -> do
5958 ~(d', x) <- dx d
60− ~(d'', y) <- runDeclareT (f x) (d <> d')
61− return (d' <> d'', y)
59+ ~(d'', y) <- runDeclareT (f x) (mappend d d')
60+ return (mappend d' d'', y)
6261
6362instance Monoid d => MonadTrans (DeclareT d) where
6463 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
src/Data/Swagger/Internal.hs+146−29
@@ -29,17 +29,19 @@ import Control.Applicative
2929import Data.Aeson
3030import qualified Data.Aeson.Types as JSON
3131import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32+import Data.Hashable (Hashable)
3233import qualified Data.HashMap.Strict as HashMap
34+import Data.HashSet.InsOrd (InsOrdHashSet)
3335import Data.Map (Map)
3436import qualified Data.Map as Map
35−import Data.Monoid
37+import Data.Monoid (Monoid (..))
38+import Data.Semigroup.Compat (Semigroup (..))
3639import Data.Scientific (Scientific)
37−import Data.Set (Set)
3840import Data.String (IsString(..))
3941import Data.Text (Text)
4042import qualified Data.Text as Text
4143import GHC.Generics (Generic)
42−import Network (HostName, PortNumber)
44+import Network.Socket (HostName, PortNumber)
4345import Network.HTTP.Media (MediaType)
4446import Text.Read (readMaybe)
4547
@@ -64,6 +66,10 @@ import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)
6466#define DEFINE_TOENCODING
6567#endif
6668
69+-- $setup
70+-- >>> :seti -XDataKinds
71+-- >>> import Data.Aeson
72+
6773-- | A list of definitions that can be used in references.
6874type Definitions = InsOrdHashMap Text
6975
@@ -111,7 +117,7 @@ data Swagger = Swagger
111117 , _swaggerResponses :: Definitions Response
112118
113119 -- | Security scheme definitions that can be used across the specification.
114− , _swaggerSecurityDefinitions :: Definitions SecurityScheme
120+ , _swaggerSecurityDefinitions :: SecurityDefinitions
115121
116122 -- | A declaration of which security schemes are applied for the API as a whole.
117123 -- The list of values describes alternative security schemes that can be used
@@ -124,7 +130,7 @@ data Swagger = Swagger
124130 -- Not all tags that are used by the Operation Object must be declared.
125131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
126132 -- Each tag name in the list MUST be unique.
127− , _swaggerTags :: Set Tag
133+ , _swaggerTags :: InsOrdHashSet Tag
128134
129135 -- | Additional external documentation.
130136 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -246,7 +252,7 @@ data PathItem = PathItem
246252data Operation = Operation
247253 { -- | A list of tags for API documentation control.
248254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
249− _operationTags :: Set TagName
255+ _operationTags :: InsOrdHashSet TagName
250256
251257 -- | A short summary of what the operation does.
252258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -303,7 +309,7 @@ data Operation = Operation
303309 } deriving (Eq, Show, Generic, Data, Typeable)
304310
305311newtype MimeList = MimeList { getMimeList :: [MediaType] }
306− deriving (Eq, Show, Monoid, Typeable)
312+ deriving (Eq, Show, Semigroup, Monoid, Typeable)
307313
308314mimeListConstr :: Constr
309315mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -556,7 +562,7 @@ data Schema = Schema
556562
557563 , _schemaAllOf :: Maybe [Referenced Schema]
558564 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
559− , _schemaAdditionalProperties :: Maybe (Referenced Schema)
565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties
560566
561567 , _schemaDiscriminator :: Maybe Text
562568 , _schemaReadOnly :: Maybe Bool
@@ -588,7 +594,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
588594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
589595 _paramSchemaDefault :: Maybe Value
590596
591− , _paramSchemaType :: SwaggerType t
597+ , _paramSchemaType :: Maybe (SwaggerType t)
592598 , _paramSchemaFormat :: Maybe Format
593599 , _paramSchemaItems :: Maybe (SwaggerItems t)
594600 , _paramSchemaMaximum :: Maybe Scientific
@@ -605,7 +611,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
605611 , _paramSchemaMultipleOf :: Maybe Scientific
606612 } deriving (Eq, Show, Generic, Typeable)
607613
608−deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)
614+deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
609615
610616data Xml = Xml
611617 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -749,12 +755,28 @@ data SecurityScheme = SecurityScheme
749755 , _securitySchemeDescription :: Maybe Text
750756 } deriving (Eq, Show, Generic, Data, Typeable)
751757
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+
752774-- | Lists the required security schemes to execute this operation.
753775-- The object can have multiple security schemes declared in it which are all required
754776-- (that is, there is a logical AND between the schemes).
755777newtype SecurityRequirement = SecurityRequirement
756778 { getSecurityRequirement :: InsOrdHashMap Text [Text]
757− } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
779+ } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
758780
759781-- | Tag name.
760782type TagName = Text
@@ -773,6 +795,8 @@ data Tag = Tag
773795 , _tagExternalDocs :: Maybe ExternalDocs
774796 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
775797
798+instance Hashable Tag
799+
776800instance IsString Tag where
777801 fromString s = Tag (fromString s) Nothing Nothing
778802
@@ -786,6 +810,8 @@ data ExternalDocs = ExternalDocs
786810 , _externalDocsUrl :: URL
787811 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
788812
813+instance Hashable ExternalDocs
814+
789815-- | A simple object to allow referencing other definitions in the specification.
790816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
791817newtype Reference = Reference { getReference :: Text }
@@ -799,67 +825,111 @@ data Referenced a
799825instance IsString a => IsString (Referenced a) where
800826 fromString = Inline . fromString
801827
802−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)
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)
803834
804835-- =======================================================================
805836-- Monoid instances
806837-- =======================================================================
807838
839+instance Semigroup Swagger where
840+ (<>) = genericMappend
808841instance Monoid Swagger where
809842 mempty = genericMempty
810− mappend = genericMappend
843+ mappend = (<>)
811844
845+instance Semigroup Info where
846+ (<>) = genericMappend
812847instance Monoid Info where
813848 mempty = genericMempty
814− mappend = genericMappend
849+ mappend = (<>)
815850
851+instance Semigroup Contact where
852+ (<>) = genericMappend
816853instance Monoid Contact where
817854 mempty = genericMempty
818− mappend = genericMappend
855+ mappend = (<>)
819856
857+instance Semigroup PathItem where
858+ (<>) = genericMappend
820859instance Monoid PathItem where
821860 mempty = genericMempty
822− mappend = genericMappend
861+ mappend = (<>)
823862
863+instance Semigroup Schema where
864+ (<>) = genericMappend
824865instance Monoid Schema where
825866 mempty = genericMempty
826− mappend = genericMappend
867+ mappend = (<>)
827868
869+instance Semigroup (ParamSchema t) where
870+ (<>) = genericMappend
828871instance Monoid (ParamSchema t) where
829872 mempty = genericMempty
830− mappend = genericMappend
873+ mappend = (<>)
831874
875+instance Semigroup Param where
876+ (<>) = genericMappend
832877instance Monoid Param where
833878 mempty = genericMempty
834− mappend = genericMappend
879+ mappend = (<>)
835880
881+instance Semigroup ParamOtherSchema where
882+ (<>) = genericMappend
836883instance Monoid ParamOtherSchema where
837884 mempty = genericMempty
838− mappend = genericMappend
885+ mappend = (<>)
839886
887+instance Semigroup Header where
888+ (<>) = genericMappend
840889instance Monoid Header where
841890 mempty = genericMempty
842− mappend = genericMappend
891+ mappend = (<>)
843892
893+instance Semigroup Responses where
894+ (<>) = genericMappend
844895instance Monoid Responses where
845896 mempty = genericMempty
846− mappend = genericMappend
897+ mappend = (<>)
847898
899+instance Semigroup Response where
900+ (<>) = genericMappend
848901instance Monoid Response where
849902 mempty = genericMempty
850− mappend = genericMappend
903+ mappend = (<>)
851904
905+instance Semigroup ExternalDocs where
906+ (<>) = genericMappend
852907instance Monoid ExternalDocs where
853908 mempty = genericMempty
854− mappend = genericMappend
909+ mappend = (<>)
855910
911+instance Semigroup Operation where
912+ (<>) = genericMappend
856913instance Monoid Operation where
857914 mempty = genericMempty
858− mappend = genericMappend
915+ mappend = (<>)
859916
917+instance Semigroup Example where
918+ (<>) = genericMappend
860919instance Monoid Example where
861920 mempty = genericMempty
862− mappend = genericMappend
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 = (<>)
863933
864934-- =======================================================================
865935-- SwaggerMonoid helper instances
@@ -875,6 +945,8 @@ instance SwaggerMonoid Responses
875945instance SwaggerMonoid Response
876946instance SwaggerMonoid ExternalDocs
877947instance SwaggerMonoid Operation
948+instance SwaggerMonoid SecurityDefinitions
949+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
878950
879951instance SwaggerMonoid MimeList
880952deriving instance SwaggerMonoid URL
@@ -893,7 +965,7 @@ instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
893965
894966instance Monoid a => SwaggerMonoid (Referenced a) where
895967 swaggerMempty = Inline mempty
896− swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
968+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
897969 swaggerMappend _ y = y
898970
899971instance SwaggerMonoid ParamAnySchema where
@@ -1016,11 +1088,22 @@ instance ToJSON Header where
10161088 toJSON = sopSwaggerGenericToJSON
10171089 DEFINE_TOENCODING
10181090
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+--
10191097instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
10201098 toJSON (SwaggerItemsPrimitive fmt schema) = object
10211099 [ "collectionFormat" .= fmt
10221100 , "items" .= schema ]
10231101 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102+ toJSON (SwaggerItemsArray []) = object
1103+ [ "items" .= object []
1104+ , "maxItems" .= (0 :: Int)
1105+ , "example" .= Array mempty
1106+ ]
10241107 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
10251108
10261109instance ToJSON Host where
@@ -1063,6 +1146,9 @@ instance ToJSON PathItem where
10631146instance ToJSON Example where
10641147 toJSON = toJSON . Map.mapKeys show . getExample
10651148
1149+instance ToJSON SecurityDefinitions where
1150+ toJSON (SecurityDefinitions sd) = toJSON sd
1151+
10661152instance ToJSON Reference where
10671153 toJSON (Reference ref) = object [ "$ref" .= ref ]
10681154
@@ -1096,6 +1182,10 @@ instance ToJSON (ParamSchema k) where
10961182 toJSON = sopSwaggerGenericToJSONWithOpts $
10971183 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
10981184
1185+instance ToJSON AdditionalProperties where
1186+ toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187+ toJSON (AdditionalPropertiesSchema s) = toJSON s
1188+
10991189-- =======================================================================
11001190-- Manual FromJSON instances
11011191-- =======================================================================
@@ -1133,7 +1223,13 @@ instance FromJSON SecurityScheme where
11331223 parseJSON = sopSwaggerGenericParseJSON
11341224
11351225instance FromJSON Schema where
1136− parseJSON = sopSwaggerGenericParseJSON
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
11371233
11381234instance FromJSON Header where
11391235 parseJSON = sopSwaggerGenericParseJSON
@@ -1148,8 +1244,21 @@ instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
11481244 <$> o .:? "collectionFormat"
11491245 <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
11501246
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+--
11511258instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1152− parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
1259+ parseJSON js@(Object obj)
1260+ | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1261+ | otherwise = SwaggerItemsObject <$> parseJSON js
11531262 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
11541263 parseJSON _ = empty
11551264
@@ -1201,6 +1310,9 @@ instance FromJSON Operation where
12011310instance FromJSON PathItem where
12021311 parseJSON = sopSwaggerGenericParseJSON
12031312
1313+instance FromJSON SecurityDefinitions where
1314+ parseJSON js = SecurityDefinitions <$> parseJSON js
1315+
12041316instance FromJSON Reference where
12051317 parseJSON (Object o) = Reference <$> o .: "$ref"
12061318 parseJSON _ = empty
@@ -1251,6 +1363,10 @@ instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
12511363instance FromJSON (ParamSchema 'SwaggerKindSchema) where
12521364 parseJSON = sopSwaggerGenericParseJSON
12531365
1366+instance FromJSON AdditionalProperties where
1367+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1368+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1369+
12541370-------------------------------------------------------------------------------
12551371-- TH splices
12561372-------------------------------------------------------------------------------
@@ -1308,3 +1424,4 @@ instance AesonDefaultValue (SwaggerType a)
13081424instance AesonDefaultValue MimeList where defaultValue = Just mempty
13091425instance AesonDefaultValue Info
13101426instance AesonDefaultValue ParamLocation
1427+instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty
src/Data/Swagger/Internal/AesonUtils.hs+16−3
@@ -44,10 +44,10 @@ import qualified Data.Text as T
4444import qualified Data.HashMap.Strict as HM
4545import qualified Data.Set as Set
4646import qualified Data.HashMap.Strict.InsOrd as InsOrd
47+import qualified Data.HashSet.InsOrd as InsOrdHS
4748
4849#if MIN_VERSION_aeson(0,10,0)
4950import Data.Aeson (Encoding, pairs, (.=), Series)
50−import Data.Monoid ((<>))
5151#endif
5252
5353-------------------------------------------------------------------------------
@@ -68,10 +68,10 @@ mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
6868makeLenses ''SwaggerAesonOptions
6969
7070class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
71− swaggerAesonOptions :: proxy a -> SwaggerAesonOptions
71+ swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions
7272
7373 -- So far we use only default definitions
74− aesonDefaults :: proxy a -> POP Maybe (Code a)
74+ aesonDefaults :: Proxy a -> POP Maybe (Code a)
7575 aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
7676
7777-------------------------------------------------------------------------------
@@ -86,6 +86,7 @@ instance AesonDefaultValue Text where defaultValue = Nothing
8686instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
8787instance AesonDefaultValue [a] where defaultValue = Just []
8888instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
89+instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty
8990instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
9091
9192-------------------------------------------------------------------------------
@@ -145,7 +146,11 @@ sopSwaggerGenericToJSON'
145146 -> DatatypeInfo '[xs]
146147 -> POP Maybe '[xs]
147148 -> [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
148152sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
153+#endif
149154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
150155sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
151156
@@ -221,7 +226,11 @@ sopSwaggerGenericParseJSON'
221226 -> DatatypeInfo '[xs]
222227 -> POP Maybe '[xs]
223228 -> 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
224232sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
233+#endif
225234 SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
226235sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
227236
@@ -293,7 +302,11 @@ sopSwaggerGenericToEncoding'
293302 -> DatatypeInfo '[xs]
294303 -> POP Maybe '[xs]
295304 -> 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
296308sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
309+#endif
297310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
298311sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
299312
src/Data/Swagger/Internal/ParamSchema.hs+60−25
@@ -22,7 +22,7 @@
2222module Data.Swagger.Internal.ParamSchema where
2323
2424import Control.Lens
25−import Data.Aeson
25+import Data.Aeson (ToJSON (..))
2626import Data.Proxy
2727import GHC.Generics
2828
@@ -31,6 +31,7 @@ import "unordered-containers" Data.HashSet (HashSet)
3131import Data.Monoid
3232import Data.Set (Set)
3333import Data.Scientific
34+import Data.Fixed (HasResolution(..), Fixed, Pico)
3435import qualified Data.Text as T
3536import qualified Data.Text.Lazy as TL
3637import Data.Time
@@ -38,8 +39,11 @@ import qualified Data.Vector as V
3839import qualified Data.Vector.Primitive as VP
3940import qualified Data.Vector.Storable as VS
4041import qualified Data.Vector.Unboxed as VU
42+import Data.Version (Version)
43+import Numeric.Natural.Compat (Natural)
4144import Data.Word
4245import Data.UUID.Types (UUID)
46+import Web.Cookie (SetCookie)
4347
4448import Data.Swagger.Internal
4549import Data.Swagger.Lens
@@ -55,20 +59,20 @@ import GHC.TypeLits (TypeError, ErrorMessage(..))
5559-- | Default schema for binary data (any sequence of octets).
5660binaryParamSchema :: ParamSchema t
5761binaryParamSchema = mempty
58− & type_ .~ SwaggerString
62+ & type_ ?~ SwaggerString
5963 & format ?~ "binary"
6064
6165-- | Default schema for binary data (base64 encoded).
6266byteParamSchema :: ParamSchema t
6367byteParamSchema = mempty
64− & type_ .~ SwaggerString
68+ & type_ ?~ SwaggerString
6569 & format ?~ "byte"
6670
6771-- | Default schema for password string.
6872-- @"password"@ format is used to hint UIs the input needs to be obscured.
6973passwordParamSchema :: ParamSchema t
7074passwordParamSchema = mempty
71− & type_ .~ SwaggerString
75+ & type_ ?~ SwaggerString
7276 & format ?~ "password"
7377
7478-- | Convert a type into a plain @'ParamSchema'@.
@@ -84,7 +88,7 @@ passwordParamSchema = mempty
8488--
8589-- instance ToParamSchema Direction where
8690-- toParamSchema _ = mempty
87−-- & type_ .~ SwaggerString
91+-- & type_ ?~ SwaggerString
8892-- & enum_ ?~ [ \"Up\", \"Down\" ]
8993-- @
9094--
@@ -111,18 +115,24 @@ class ToParamSchema a where
111115 --
112116 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
113117 -- "{\"type\":\"integer\"}"
114− toParamSchema :: proxy a -> ParamSchema t
115− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
118+ toParamSchema :: Proxy a -> ParamSchema t
119+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
116120 toParamSchema = genericToParamSchema defaultSchemaOptions
117121
118122instance OVERLAPPING_ ToParamSchema String where
119− toParamSchema _ = mempty & type_ .~ SwaggerString
123+ toParamSchema _ = mempty & type_ ?~ SwaggerString
120124
121125instance ToParamSchema Bool where
122− toParamSchema _ = mempty & type_ .~ SwaggerBoolean
126+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
123127
124128instance ToParamSchema Integer where
125− toParamSchema _ = mempty & type_ .~ SwaggerInteger
129+ toParamSchema _ = mempty & type_ ?~ SwaggerInteger
130+
131+instance ToParamSchema Natural where
132+ toParamSchema _ = mempty
133+ & type_ ?~ SwaggerInteger
134+ & minimum_ ?~ 0
135+ & exclusiveMinimum ?~ False
126136
127137instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
128138instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -144,40 +154,51 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
144154--
145155-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
146156-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
147−toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
157+toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
148158toParamSchemaBoundedIntegral _ = mempty
149− & type_ .~ SwaggerInteger
159+ & type_ ?~ SwaggerInteger
150160 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
151161 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
152162
153163instance ToParamSchema Char where
154164 toParamSchema _ = mempty
155− & type_ .~ SwaggerString
165+ & type_ ?~ SwaggerString
156166 & maxLength ?~ 1
157167 & minLength ?~ 1
158168
159169instance ToParamSchema Scientific where
160− toParamSchema _ = mempty & type_ .~ SwaggerNumber
170+ toParamSchema _ = mempty & type_ ?~ SwaggerNumber
171+
172+instance HasResolution a => ToParamSchema (Fixed a) where
173+ toParamSchema _ = mempty
174+ & type_ ?~ SwaggerNumber
175+ & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
161176
162177instance ToParamSchema Double where
163178 toParamSchema _ = mempty
164− & type_ .~ SwaggerNumber
179+ & type_ ?~ SwaggerNumber
165180 & format ?~ "double"
166181
167182instance ToParamSchema Float where
168183 toParamSchema _ = mempty
169− & type_ .~ SwaggerNumber
184+ & type_ ?~ SwaggerNumber
170185 & format ?~ "float"
171186
172187timeParamSchema :: String -> ParamSchema t
173188timeParamSchema fmt = mempty
174− & type_ .~ SwaggerString
189+ & type_ ?~ SwaggerString
175190 & format ?~ T.pack fmt
176191
177192-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
178193instance ToParamSchema Day where
179194 toParamSchema _ = timeParamSchema "date"
180195
196+-- |
197+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198+-- Just "hh:MM:ss"
199+instance ToParamSchema TimeOfDay where
200+ toParamSchema _ = timeParamSchema "hh:MM:ss"
201+
181202-- |
182203-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
183204-- Just "yyyy-mm-ddThh:MM:ss"
@@ -197,7 +218,7 @@ instance ToParamSchema UTCTime where
197218 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
198219
199220instance ToParamSchema NominalDiffTime where
200− toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
221+ toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
201222
202223instance ToParamSchema T.Text where
203224 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -205,6 +226,16 @@ instance ToParamSchema T.Text where
205226instance ToParamSchema TL.Text where
206227 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
207228
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+
208239#if __GLASGOW_HASKELL__ < 800
209240#else
210241type family ToParamSchemaByteStringError bs where
@@ -225,9 +256,11 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
225256instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
226257instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
227258
259+instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
260+
228261instance ToParamSchema a => ToParamSchema [a] where
229262 toParamSchema _ = mempty
230− & type_ .~ SwaggerArray
263+ & type_ ?~ SwaggerArray
231264 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
232265
233266instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -247,12 +280,12 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
247280-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
248281instance ToParamSchema () where
249282 toParamSchema _ = mempty
250− & type_ .~ SwaggerString
283+ & type_ ?~ SwaggerString
251284 & enum_ ?~ ["_"]
252285
253286instance ToParamSchema UUID where
254287 toParamSchema _ = mempty
255− & type_ .~ SwaggerString
288+ & type_ ?~ SwaggerString
256289 & format ?~ "uuid"
257290
258291-- | A configurable generic @'ParamSchema'@ creator.
@@ -261,11 +294,11 @@ instance ToParamSchema UUID where
261294-- >>> data Color = Red | Blue deriving Generic
262295-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
263296-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
264−genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
297+genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
265298genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
266299
267300class GToParamSchema (f :: * -> *) where
268− gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
301+ gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
269302
270303instance GToParamSchema f => GToParamSchema (D1 d f) where
271304 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -283,14 +316,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
283316 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
284317
285318class GEnumParamSchema (f :: * -> *) where
286− genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
319+ genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
287320
288321instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
289322 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
290323
291324instance Constructor c => GEnumParamSchema (C1 c U1) where
292325 genumParamSchema opts _ s = s
293− & type_ .~ SwaggerString
326+ & type_ ?~ SwaggerString
294327 & enum_ %~ addEnumValue tag
295328 where
296329 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -300,3 +333,5 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
300333
301334data Proxy3 a b c = Proxy3
302335
336+-- $setup
337+-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hs+159−68
@@ -32,7 +32,7 @@ import Data.Data.Lens (template)
3232
3333import Control.Monad
3434import Control.Monad.Writer
35−import Data.Aeson
35+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
3636import Data.Char
3737import Data.Data (Data)
3838import Data.Foldable (traverse_)
@@ -44,9 +44,11 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
4444import Data.Int
4545import Data.IntSet (IntSet)
4646import Data.IntMap (IntMap)
47+import Data.List.NonEmpty.Compat (NonEmpty)
4748import Data.Map (Map)
4849import Data.Proxy
4950import Data.Scientific (Scientific)
51+import Data.Fixed (Fixed, HasResolution, Pico)
5052import Data.Set (Set)
5153import qualified Data.Text as T
5254import qualified Data.Text.Lazy as TL
@@ -55,6 +57,8 @@ import qualified Data.Vector as V
5557import qualified Data.Vector.Primitive as VP
5658import qualified Data.Vector.Storable as VS
5759import qualified Data.Vector.Unboxed as VU
60+import Data.Version (Version)
61+import Numeric.Natural.Compat (Natural)
5862import Data.Word
5963import GHC.Generics
6064import qualified Data.UUID.Types as UUID
@@ -107,7 +111,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
107111-- declareNamedSchema _ = do
108112-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
109113-- return $ NamedSchema (Just \"Coord\") $ mempty
110−-- & type_ .~ SwaggerObject
114+-- & type_ ?~ SwaggerObject
111115-- & properties .~
112116-- [ (\"x\", doubleSchema)
113117-- , (\"y\", doubleSchema)
@@ -138,13 +142,17 @@ class ToSchema a where
138142 -- together with all used definitions.
139143 -- Note that the schema itself is included in definitions
140144 -- only if it is recursive (and thus needs its definition in scope).
141− declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
145+ declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
142146 default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
143− proxy a -> Declare (Definitions Schema) NamedSchema
147+ Proxy a -> Declare (Definitions Schema) NamedSchema
144148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
145149
150+instance ToSchema TimeOfDay where
151+ declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152+ & example ?~ toJSON (TimeOfDay 12 33 15)
153+
146154-- | Convert a type into a schema and declare all used schema definitions.
147−declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
155+declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
148156declareSchema = fmap _namedSchemaSchema . declareNamedSchema
149157
150158-- | Convert a type into an optionally named schema.
@@ -158,7 +166,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
158166-- Just "Day"
159167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
160168-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
161−toNamedSchema :: ToSchema a => proxy a -> NamedSchema
169+toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
162170toNamedSchema = undeclare . declareNamedSchema
163171
164172-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -168,7 +176,7 @@ toNamedSchema = undeclare . declareNamedSchema
168176--
169177-- >>> schemaName (Proxy :: Proxy UTCTime)
170178-- Just "UTCTime"
171−schemaName :: ToSchema a => proxy a -> Maybe T.Text
179+schemaName :: ToSchema a => Proxy a -> Maybe T.Text
172180schemaName = _namedSchemaName . toNamedSchema
173181
174182-- | Convert a type into a schema.
@@ -178,7 +186,7 @@ schemaName = _namedSchemaName . toNamedSchema
178186--
179187-- >>> encode $ toSchema (Proxy :: Proxy [Day])
180188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
181−toSchema :: ToSchema a => proxy a -> Schema
189+toSchema :: ToSchema a => Proxy a -> Schema
182190toSchema = _namedSchemaSchema . toNamedSchema
183191
184192-- | Convert a type into a referenced schema if possible.
@@ -189,7 +197,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
189197--
190198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
191199-- "{\"$ref\":\"#/definitions/Day\"}"
192−toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
200+toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
193201toSchemaRef = undeclare . declareSchemaRef
194202
195203-- | Convert a type into a referenced schema if possible
@@ -199,7 +207,7 @@ toSchemaRef = undeclare . declareSchemaRef
199207-- Schema definitions are typically declared for every referenced schema.
200208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
201209-- will be declared (regardless of whether it is recusive or not).
202−declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
210+declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
203211declareSchemaRef proxy = do
204212 case toNamedSchema proxy of
205213 NamedSchema (Just name) schema -> do
@@ -261,7 +269,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)
261269--
262270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
263271-- when inlining recursive schemas.
264−toInlinedSchema :: ToSchema a => proxy a -> Schema
272+toInlinedSchema :: ToSchema a => Proxy a -> Schema
265273toInlinedSchema proxy = inlineAllSchemas defs schema
266274 where
267275 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -290,20 +298,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
290298-- | Default schema for binary data (any sequence of octets).
291299binarySchema :: Schema
292300binarySchema = mempty
293− & type_ .~ SwaggerString
301+ & type_ ?~ SwaggerString
294302 & format ?~ "binary"
295303
296304-- | Default schema for binary data (base64 encoded).
297305byteSchema :: Schema
298306byteSchema = mempty
299− & type_ .~ SwaggerString
307+ & type_ ?~ SwaggerString
300308 & format ?~ "byte"
301309
302310-- | Default schema for password string.
303311-- @"password"@ format is used to hint UIs the input needs to be obscured.
304312passwordSchema :: Schema
305313passwordSchema = mempty
306− & type_ .~ SwaggerString
314+ & type_ ?~ SwaggerString
307315 & format ?~ "password"
308316
309317-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -329,12 +337,12 @@ sketchSchema = sketch . toJSON
329337 sketch js@(Bool _) = go js
330338 sketch js = go js & example ?~ js
331339
332− go Null = mempty & type_ .~ SwaggerNull
333− go (Bool _) = mempty & type_ .~ SwaggerBoolean
334− go (String _) = mempty & type_ .~ SwaggerString
335− go (Number _) = mempty & type_ .~ SwaggerNumber
340+ go Null = mempty & type_ ?~ SwaggerNull
341+ go (Bool _) = mempty & type_ ?~ SwaggerBoolean
342+ go (String _) = mempty & type_ ?~ SwaggerString
343+ go (Number _) = mempty & type_ ?~ SwaggerNumber
336344 go (Array xs) = mempty
337− & type_ .~ SwaggerArray
345+ & type_ ?~ SwaggerArray
338346 & items ?~ case ischema of
339347 Just s -> SwaggerItemsObject (Inline s)
340348 _ -> SwaggerItemsArray (map Inline ys)
@@ -346,7 +354,7 @@ sketchSchema = sketch . toJSON
346354 (z:_) | allSame -> Just z
347355 _ -> Nothing
348356 go (Object o) = mempty
349− & type_ .~ SwaggerObject
357+ & type_ ?~ SwaggerObject
350358 & required .~ HashMap.keys o
351359 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
352360
@@ -369,24 +377,24 @@ sketchSchema = sketch . toJSON
369377sketchStrictSchema :: ToJSON a => a -> Schema
370378sketchStrictSchema = go . toJSON
371379 where
372− go Null = mempty & type_ .~ SwaggerNull
380+ go Null = mempty & type_ ?~ SwaggerNull
373381 go js@(Bool _) = mempty
374− & type_ .~ SwaggerBoolean
382+ & type_ ?~ SwaggerBoolean
375383 & enum_ ?~ [js]
376384 go js@(String s) = mempty
377− & type_ .~ SwaggerString
385+ & type_ ?~ SwaggerString
378386 & maxLength ?~ fromIntegral (T.length s)
379387 & minLength ?~ fromIntegral (T.length s)
380388 & pattern ?~ s
381389 & enum_ ?~ [js]
382390 go js@(Number n) = mempty
383− & type_ .~ SwaggerNumber
391+ & type_ ?~ SwaggerNumber
384392 & maximum_ ?~ n
385393 & minimum_ ?~ n
386394 & multipleOf ?~ n
387395 & enum_ ?~ [js]
388396 go js@(Array xs) = mempty
389− & type_ .~ SwaggerArray
397+ & type_ ?~ SwaggerArray
390398 & maxItems ?~ fromIntegral sz
391399 & minItems ?~ fromIntegral sz
392400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -396,7 +404,7 @@ sketchStrictSchema = go . toJSON
396404 sz = length xs
397405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
398406 go js@(Object o) = mempty
399− & type_ .~ SwaggerObject
407+ & type_ ?~ SwaggerObject
400408 & required .~ names
401409 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
402410 & maxProperties ?~ fromIntegral (length names)
@@ -406,18 +414,19 @@ sketchStrictSchema = go . toJSON
406414 names = HashMap.keys o
407415
408416class GToSchema (f :: * -> *) where
409− gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
417+ gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
410418
411419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
412420 declareNamedSchema _ = do
413421 ref <- declareSchemaRef (Proxy :: Proxy a)
414422 return $ unnamed $ mempty
415− & type_ .~ SwaggerArray
423+ & type_ ?~ SwaggerArray
416424 & items ?~ SwaggerItemsObject ref
417425
418426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
419427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
420428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429+instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
421430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
422431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
423432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -437,6 +446,8 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
437446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
438447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
439448
449+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450+
440451instance ToSchema a => ToSchema (Maybe a) where
441452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
442453
@@ -459,7 +470,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
459470
460471timeSchema :: T.Text -> Schema
461472timeSchema fmt = mempty
462− & type_ .~ SwaggerString
473+ & type_ ?~ SwaggerString
463474 & format ?~ fmt
464475
465476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -480,7 +491,7 @@ instance ToSchema ZonedTime where
480491 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
481492
482493instance ToSchema NominalDiffTime where
483− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
494+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
484495
485496-- |
486497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
@@ -492,6 +503,8 @@ instance ToSchema UTCTime where
492503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
493504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
494505
506+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
507+
495508#if __GLASGOW_HASKELL__ < 800
496509#else
497510type family ToSchemaByteStringError bs where
@@ -519,8 +532,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
519532 declareObjectMapSchema = do
520533 schema <- declareSchemaRef (Proxy :: Proxy v)
521534 return $ unnamed $ mempty
522− & type_ .~ SwaggerObject
523− & additionalProperties ?~ schema
535+ & type_ ?~ SwaggerObject
536+ & additionalProperties ?~ AdditionalPropertiesSchema schema
524537
525538instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
526539 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
@@ -531,7 +544,7 @@ instance ToSchema a => ToSchema (Map String a) where
531544 declareNamedSchema _ = do
532545 schema <- declareSchemaRef (Proxy :: Proxy a)
533546 return $ unnamed $ mempty
534− & type_ .~ SwaggerObject
547+ & type_ ?~ SwaggerObject
535548 & additionalProperties ?~ schema
536549
537550instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -543,6 +556,12 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =
543556
544557#endif
545558
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+
546565instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
547566instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
548567instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -556,6 +575,13 @@ instance ToSchema a => ToSchema (Set a) where
556575
557576instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
558577
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+
559585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
560586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
561587
@@ -565,78 +591,141 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
565591instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
566592instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
567593
594+instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595+
568596-- | Default schema for @'Bounded'@, @'Integral'@ types.
569597--
570598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
571599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
572−toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
600+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
573601toSchemaBoundedIntegral _ = mempty
574− & type_ .~ SwaggerInteger
602+ & type_ ?~ SwaggerInteger
575603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
576604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
577605
578606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
579−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
607+genericToNamedSchemaBoundedIntegral :: forall a d f.
580608 ( Bounded a, Integral a
581609 , Generic a, Rep a ~ D1 d f, Datatype d)
582− => SchemaOptions -> proxy a -> NamedSchema
610+ => SchemaOptions -> Proxy a -> NamedSchema
583611genericToNamedSchemaBoundedIntegral opts proxy
584− = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
612+ = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
613+
614+-- | Declare a named schema for a @newtype@ wrapper.
615+genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
616+ (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617+ => SchemaOptions -- ^ How to derive the name.
618+ -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619+ -> Proxy a
620+ -> Declare (Definitions Schema) NamedSchema
621+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622+
623+-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
624+-- This makes a much more useful schema when there aren't many options for key values.
625+--
626+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
627+-- >>> instance ToJSON ButtonState
628+-- >>> instance ToSchema ButtonState
629+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
630+-- >>> type ImageUrl = T.Text
631+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
632+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
633+--
634+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636+declareSchemaBoundedEnumKeyMapping :: forall map key value.
637+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638+ => Proxy (map key value) -> Declare (Definitions Schema) Schema
639+declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640+ ToJSONKeyText keyToText _ -> objectSchema keyToText
641+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
642+ where
643+ objectSchema keyToText = do
644+ valueRef <- declareSchemaRef (Proxy :: Proxy value)
645+ let allKeys = [minBound..maxBound :: key]
646+ mkPair k = (keyToText k, valueRef)
647+ return $ mempty
648+ & type_ ?~ SwaggerObject
649+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650+
651+-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
652+-- This makes a much more useful schema when there aren't many options for key values.
653+--
654+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
655+-- >>> instance ToJSON ButtonState
656+-- >>> instance ToSchema ButtonState
657+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
658+-- >>> type ImageUrl = T.Text
659+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
660+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
661+--
662+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664+toSchemaBoundedEnumKeyMapping :: forall map key value.
665+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666+ => Proxy (map key value) -> Schema
667+toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
585668
586669-- | A configurable generic @'Schema'@ creator.
587670genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
588− SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
671+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
589672genericDeclareSchema = genericDeclareSchemaUnrestricted
590673
591674-- | A configurable generic @'NamedSchema'@ creator.
592675-- This function applied to @'defaultSchemaOptions'@
593676-- is used as the default for @'declareNamedSchema'@
594677-- when the type is an instance of @'Generic'@.
595−genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
596− SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
678+genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
679+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
597680genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
598681
599682-- | A configurable generic @'Schema'@ creator.
600683--
601684-- Unlike 'genericDeclareSchema' also works for mixed sum types.
602685-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
603−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
686+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
604687genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
605688
606689-- | A configurable generic @'NamedSchema'@ creator.
607690--
608691-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
609692-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
610−genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) =>
611− SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
693+genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
694+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
612695genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
613696
614−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
615−gdatatypeSchemaName opts _ = case name of
697+-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698+genericNameSchema :: forall a d f.
699+ (Generic a, Rep a ~ D1 d f, Datatype d)
700+ => SchemaOptions -> Proxy a -> Schema -> NamedSchema
701+genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
702+
703+gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704+gdatatypeSchemaName opts _ = case orig of
616705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
617706 _ -> Nothing
618707 where
619− name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
708+ orig = datatypeName (Proxy3 :: Proxy3 d f a)
709+ name = datatypeNameModifier opts orig
620710
621711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
622−paramSchemaToNamedSchema :: forall a d f proxy.
623− (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
624− => SchemaOptions -> proxy a -> NamedSchema
625−paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
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)
626715
627716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
628−paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
629−paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
717+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718+paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
630719
631720nullarySchema :: Schema
632721nullarySchema = mempty
633− & type_ .~ SwaggerArray
722+ & type_ ?~ SwaggerArray
634723 & items ?~ SwaggerItemsArray []
635724
636−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
725+gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
637726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
638727
639−gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
728+gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
640729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
641730
642731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -656,7 +745,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
656745 gdeclareNamedSchema = gdeclareNamedSumSchema
657746
658747-- | Single field constructor.
659−instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
748+instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
660749 gdeclareNamedSchema opts _ s
661750 | unwrapUnaryRecords opts = fieldSchema
662751 | otherwise =
@@ -670,7 +759,7 @@ instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
670759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
671760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
672761
673−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
762+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
674763gdeclareSchemaRef opts proxy = do
675764 case gtoNamedSchema opts proxy of
676765 NamedSchema (Just name) schema -> do
@@ -701,12 +790,12 @@ withFieldSchema opts _ isRequiredField schema = do
701790 return $
702791 if T.null fname
703792 then schema
704− & type_ .~ SwaggerArray
793+ & type_ ?~ SwaggerArray
705794 & items %~ appendItem ref
706795 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
707796 & minItems %~ Just . maybe 1 (+1) -- increment minItems
708797 else schema
709− & type_ .~ SwaggerObject
798+ & type_ ?~ SwaggerObject
710799 & properties . at fname ?~ ref
711800 & if isRequiredField
712801 then required %~ (++ [fname])
@@ -734,7 +823,7 @@ instance ( GSumToSchema f
734823 where
735824 gdeclareNamedSchema = gdeclareNamedSumSchema
736825
737−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
826+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
738827gdeclareNamedSumSchema opts proxy s
739828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
740829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -743,29 +832,29 @@ gdeclareNamedSumSchema opts proxy s
743832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
744833
745834 toStringTag schema = mempty
746− & type_ .~ SwaggerString
835+ & type_ ?~ SwaggerString
747836 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
748837
749838type AllNullary = All
750839
751840class GSumToSchema (f :: * -> *) where
752− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
841+ gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
753842
754843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
755844 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
756845
757−gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
758− Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
846+gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847+ Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
759848gsumConToSchemaWith ref opts _ schema = schema
760− & type_ .~ SwaggerObject
849+ & type_ ?~ SwaggerObject
761850 & properties . at tag ?~ ref
762851 & maxProperties ?~ 1
763852 & minProperties ?~ 1
764853 where
765854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
766855
767−gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
768− SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
856+gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857+ SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
769858gsumConToSchema opts proxy schema = do
770859 ref <- gdeclareSchemaRef opts proxy
771860 return $ gsumConToSchemaWith ref opts proxy schema
@@ -789,3 +878,5 @@ data Proxy3 a b c = Proxy3
789878
790879-- $setup
791880-- >>> import Data.Swagger
881+-- >>> import Data.Aeson (encode)
882+-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hs+242−56
@@ -1,15 +1,17 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE GADTs #-}
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
57{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PackageImports #-}
9−{-# LANGUAGE RankNTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TemplateHaskell #-}
12−{-# LANGUAGE UndecidableInstances #-}
8+{-# LANGUAGE LambdaCase #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PackageImports #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TemplateHaskell #-}
14+{-# LANGUAGE UndecidableInstances #-}
1315-- |
1416-- Module: Data.Swagger.Internal.Schema.Validation
1517-- Copyright: (c) 2015 GetShopTV
@@ -20,28 +22,34 @@
2022-- Validate JSON values with Swagger Schema.
2123module Data.Swagger.Internal.Schema.Validation where
2224
23−import Control.Applicative
24−import Control.Lens
25−import Control.Monad (when)
25+import Prelude ()
26+import Prelude.Compat
2627
27−import Data.Aeson hiding (Result)
28−import Data.Foldable (traverse_, for_, sequenceA_)
29−import Data.HashMap.Strict (HashMap)
30−import qualified Data.HashMap.Strict as HashMap
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
3139import qualified "unordered-containers" Data.HashSet as HashSet
32−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
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
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
4553
4654-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
4755-- This can be used with QuickCheck to ensure those instances are coherent:
@@ -50,22 +58,119 @@ import Data.Swagger.Lens
5058--
5159-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
5260-- 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.
5367validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
5468validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
5569
5670-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
5771-- This can be used with QuickCheck to ensure those instances are coherent.
5872--
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 =
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 =
63170 case runValidation (validateWithSchema js) cfg sch of
64171 Failed xs -> xs
65172 Passed _ -> mempty
66173 where
67− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
68− js = toJSON x
69174 cfg = defaultConfig
70175 { configPatternChecker = checker
71176 , configDefinitions = defs }
@@ -158,12 +263,18 @@ valid = pure ()
158263
159264-- | Validate schema's property given a lens into that property
160265-- and property checker.
161−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
162−check l g = withSchema $ \sch ->
266+checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
267+checkMissing missing l g = withSchema $ \sch ->
163268 case sch ^. l of
164− Nothing -> valid
269+ Nothing -> missing
165270 Just x -> g x
166271
272+-- | Validate schema's property given a lens into that property
273+-- and property checker.
274+-- If property is missing in schema, consider it valid.
275+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
276+check = checkMissing valid
277+
167278-- | Validate same value with different schema.
168279sub :: t -> Validation t a -> Validation s a
169280sub = lmap . const
@@ -292,34 +403,109 @@ validateObject o = withSchema $ \sch ->
292403 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
293404 _ ->
294405 case InsOrdHashMap.lookup k (sch ^. properties) of
295− Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v
406+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
296407 Just s -> validateWithSchemaRef s v
297408
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+
298417validateEnum :: Value -> Validation (ParamSchema t) ()
299418validateEnum value = do
300419 check enum_ $ \xs ->
301420 when (value `notElem` xs) $
302421 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
303422
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+
304470validateSchemaType :: Value -> Validation Schema ()
305471validateSchemaType value = withSchema $ \sch ->
306472 case (sch ^. type_, value) of
307− (SwaggerNull, Null) -> valid
308− (SwaggerBoolean, Bool _) -> valid
309− (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
310− (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
311− (SwaggerString, String s) -> sub_ paramSchema (validateString s)
312− (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
313− (SwaggerObject, Object o) -> validateObject o
314− (t, _) -> invalid $ "expected JSON value of type " ++ show t
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
315488
316489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
317490validateParamSchemaType value = withSchema $ \sch ->
318491 case (sch ^. type_, value) of
319− (SwaggerBoolean, Bool _) -> valid
320− (SwaggerInteger, Number n) -> validateInteger n
321− (SwaggerNumber, Number n) -> validateNumber n
322− (SwaggerString, String s) -> validateString s
323− (SwaggerArray, Array xs) -> validateArray xs
324− (t, _) -> invalid $ "expected JSON value of type " ++ show t
325−
492+ (Just SwaggerBoolean, Bool _) -> valid
493+ (Just SwaggerInteger, Number n) -> validateInteger n
494+ (Just SwaggerNumber, Number n) -> validateNumber n
495+ (Just SwaggerString, String s) -> validateString s
496+ (Just SwaggerArray, Array xs) -> validateArray xs
497+ (Nothing, Bool _) -> valid
498+ -- Number by default
499+ (Nothing, Number n) -> validateNumber n
500+ (Nothing, String s) -> validateString s
501+ (Nothing, Array xs) -> validateArray xs
502+ bad -> invalid $ "expected JSON value of type " ++ showType bad
503+
504+showType :: (Maybe (SwaggerType t), Value) -> String
505+showType (Just type_, _) = show type_
506+showType (Nothing, Null) = "SwaggerNull"
507+showType (Nothing, Bool _) = "SwaggerBoolean"
508+showType (Nothing, Number _) = "SwaggerNumber"
509+showType (Nothing, String _) = "SwaggerString"
510+showType (Nothing, Array _) = "SwaggerArray"
511+showType (Nothing, Object _) = "SwaggerObject"
src/Data/Swagger/Internal/Utils.hs−1
@@ -21,7 +21,6 @@ import qualified Data.HashMap.Strict as HashMap
2121import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
2222import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
2323import Data.Map (Map)
24−import Data.Monoid
2524import Data.Set (Set)
2625import Data.Text (Text)
2726import GHC.Generics
src/Data/Swagger/Lens.hs+10−4
@@ -96,13 +96,19 @@ instance At Responses where at n = responses . at n
9696instance Ixed Operation where ix n = responses . ix n
9797instance At Operation where at n = responses . at n
9898
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+
99105instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
100106
101107-- HasType instances
102−instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_
103−instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_
104−instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_
105−instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_
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_
106112
107113-- HasDefault instances
108114instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
src/Data/Swagger/Operation.hs+5−5
@@ -37,7 +37,7 @@ import Control.Lens
3737import Data.Data.Lens
3838import Data.List.Compat
3939import Data.Maybe (mapMaybe)
40−import Data.Monoid
40+import Data.Proxy
4141import qualified Data.Set as Set
4242
4343import Data.Swagger.Declare
@@ -46,6 +46,7 @@ import Data.Swagger.Lens
4646import Data.Swagger.Schema
4747
4848import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49+import qualified Data.HashSet.InsOrd as InsOrdHS
4950
5051-- $setup
5152-- >>> import Data.Aeson
@@ -111,15 +112,15 @@ applyTags = applyTagsFor allOperations
111112-- list of tags.
112113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
113114applyTagsFor ops ts swag = swag
114− & ops . tags %~ (<> Set.fromList (map _tagName ts))
115− & tags %~ (<> Set.fromList ts)
115+ & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
116+ & tags %~ (<> InsOrdHS.fromList ts)
116117
117118-- | Construct a response with @'Schema'@ while declaring all
118119-- necessary schema definitions.
119120--
120121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
121122-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
122−declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
123+declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response
123124declareResponse proxy = do
124125 s <- declareSchemaRef proxy
125126 return (mempty & schema ?~ s)
@@ -190,4 +191,3 @@ setResponseForWith ops f code dres swag = swag
190191 Nothing -> new -- response name can't be dereferenced, replacing with new response
191192 combine (Just (Inline old)) = f old new
192193 combine Nothing = new
193−
src/Data/Swagger/Optics.hsnew file+597
@@ -0,0 +1,597 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedLabels #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+{-# OPTIONS_GHC -fno-warn-orphans #-}
9+-- |
10+-- Module: Data.Swagger.Optics
11+-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>
12+-- Stability: experimental
13+--
14+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>
15+-- library.
16+--
17+-- >>> import Data.Aeson
18+-- >>> import Optics.Core
19+-- >>> :set -XOverloadedLabels
20+--
21+-- Example from the "Data.Swagger" module using @optics@:
22+--
23+-- >>> :{
24+-- encode $ (mempty :: Swagger)
25+-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]
26+-- & #paths .~
27+-- [ ("/user", mempty & #get ?~ (mempty
28+-- & #produces ?~ MimeList ["application/json"]
29+-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))
30+-- & at 404 ?~ "User info not found")) ]
31+-- :}
32+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
33+--
34+-- For convenience optics are defined as /labels/. It means that field accessor
35+-- names can be overloaded for different types. One such common field is
36+-- @#description@. Many components of a Swagger specification can have
37+-- descriptions, and you can use the same name for them:
38+--
39+-- >>> encode $ (mempty :: Response) & #description .~ "No content"
40+-- "{\"description\":\"No content\"}"
41+-- >>> :{
42+-- encode $ (mempty :: Schema)
43+-- & #type ?~ SwaggerBoolean
44+-- & #description ?~ "To be or not to be"
45+-- :}
46+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
47+--
48+-- @'ParamSchema'@ is basically the /base schema specification/ and many types
49+-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively
50+-- made fields of the type that has it. For example, you can use @#type@ to
51+-- access @'SwaggerType'@ of @'Header'@ schema without having to use
52+-- @#paramSchema@:
53+--
54+-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber
55+-- "{\"type\":\"number\"}"
56+--
57+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
58+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
59+--
60+-- >>> :{
61+-- encode $ (mempty :: Operation)
62+-- & at 404 ?~ "Not found"
63+-- :}
64+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
65+--
66+module Data.Swagger.Optics () where
67+
68+import Data.Aeson (Value)
69+import Data.Scientific (Scientific)
70+import Data.Swagger.Internal
71+import Data.Text (Text)
72+import Optics.Core
73+import Optics.TH
74+
75+-- Lenses
76+
77+makeFieldLabels ''Swagger
78+makeFieldLabels ''Host
79+makeFieldLabels ''Info
80+makeFieldLabels ''Contact
81+makeFieldLabels ''License
82+makeFieldLabels ''PathItem
83+makeFieldLabels ''Tag
84+makeFieldLabels ''Operation
85+makeFieldLabels ''Param
86+makeFieldLabels ''ParamOtherSchema
87+makeFieldLabels ''Header
88+makeFieldLabels ''Schema
89+makeFieldLabels ''NamedSchema
90+makeFieldLabels ''ParamSchema
91+makeFieldLabels ''Xml
92+makeFieldLabels ''Responses
93+makeFieldLabels ''Response
94+makeFieldLabels ''SecurityScheme
95+makeFieldLabels ''ApiKeyParams
96+makeFieldLabels ''OAuth2Params
97+makeFieldLabels ''ExternalDocs
98+
99+-- Prisms
100+
101+makePrismLabels ''ParamAnySchema
102+makePrismLabels ''SecuritySchemeType
103+makePrismLabels ''Referenced
104+
105+-- SwaggerItems prisms
106+
107+instance
108+ ( a ~ [Referenced Schema]
109+ , b ~ [Referenced Schema]
110+ ) => LabelOptic "_SwaggerItemsArray"
111+ A_Review
112+ (SwaggerItems 'SwaggerKindSchema)
113+ (SwaggerItems 'SwaggerKindSchema)
114+ a
115+ b where
116+ labelOptic = unto (\x -> SwaggerItemsArray x)
117+ {-# INLINE labelOptic #-}
118+
119+instance
120+ ( a ~ Referenced Schema
121+ , b ~ Referenced Schema
122+ ) => LabelOptic "_SwaggerItemsObject"
123+ A_Review
124+ (SwaggerItems 'SwaggerKindSchema)
125+ (SwaggerItems 'SwaggerKindSchema)
126+ a
127+ b where
128+ labelOptic = unto (\x -> SwaggerItemsObject x)
129+ {-# INLINE labelOptic #-}
130+
131+instance
132+ ( a ~ (Maybe (CollectionFormat t), ParamSchema t)
133+ , b ~ (Maybe (CollectionFormat t), ParamSchema t)
134+ ) => LabelOptic "_SwaggerItemsPrimitive"
135+ A_Review
136+ (SwaggerItems t)
137+ (SwaggerItems t)
138+ a
139+ b where
140+ labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)
141+ {-# INLINE labelOptic #-}
142+
143+-- =============================================================
144+-- More helpful instances for easier access to schema properties
145+
146+type instance Index Responses = HttpStatusCode
147+type instance Index Operation = HttpStatusCode
148+
149+type instance IxValue Responses = Referenced Response
150+type instance IxValue Operation = Referenced Response
151+
152+instance Ixed Responses where
153+ ix n = #responses % ix n
154+ {-# INLINE ix #-}
155+instance At Responses where
156+ at n = #responses % at n
157+ {-# INLINE at #-}
158+
159+instance Ixed Operation where
160+ ix n = #responses % ix n
161+ {-# INLINE ix #-}
162+instance At Operation where
163+ at n = #responses % at n
164+ {-# INLINE at #-}
165+
166+-- #paramSchema
167+
168+instance
169+ ( a ~ ParamSchema 'SwaggerKindSchema
170+ , b ~ ParamSchema 'SwaggerKindSchema
171+ ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where
172+ labelOptic = #schema % #paramSchema
173+ {-# INLINE labelOptic #-}
174+
175+-- #type
176+
177+instance
178+ ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
179+ , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
180+ ) => LabelOptic "type" A_Lens Header Header a b where
181+ labelOptic = #paramSchema % #type
182+ {-# INLINE labelOptic #-}
183+
184+instance
185+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
186+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
187+ ) => LabelOptic "type" A_Lens Schema Schema a b where
188+ labelOptic = #paramSchema % #type
189+ {-# INLINE labelOptic #-}
190+
191+instance
192+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
193+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
194+ ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
195+ labelOptic = #paramSchema % #type
196+ {-# INLINE labelOptic #-}
197+
198+instance
199+ ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
200+ , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
201+ ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where
202+ labelOptic = #paramSchema % #type
203+ {-# INLINE labelOptic #-}
204+
205+-- #default
206+
207+instance
208+ ( a ~ Maybe Value, b ~ Maybe Value
209+ ) => LabelOptic "default" A_Lens Header Header a b where
210+ labelOptic = #paramSchema % #default
211+ {-# INLINE labelOptic #-}
212+
213+instance
214+ ( a ~ Maybe Value, b ~ Maybe Value
215+ ) => LabelOptic "default" A_Lens Schema Schema a b where
216+ labelOptic = #paramSchema % #default
217+ {-# INLINE labelOptic #-}
218+
219+instance
220+ ( a ~ Maybe Value, b ~ Maybe Value
221+ ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where
222+ labelOptic = #paramSchema % #default
223+ {-# INLINE labelOptic #-}
224+
225+instance
226+ ( a ~ Maybe Value, b ~ Maybe Value
227+ ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where
228+ labelOptic = #paramSchema % #default
229+ {-# INLINE labelOptic #-}
230+
231+-- #format
232+
233+instance
234+ ( a ~ Maybe Format, b ~ Maybe Format
235+ ) => LabelOptic "format" A_Lens Header Header a b where
236+ labelOptic = #paramSchema % #format
237+ {-# INLINE labelOptic #-}
238+
239+instance
240+ ( a ~ Maybe Format, b ~ Maybe Format
241+ ) => LabelOptic "format" A_Lens Schema Schema a b where
242+ labelOptic = #paramSchema % #format
243+ {-# INLINE labelOptic #-}
244+
245+instance
246+ ( a ~ Maybe Format, b ~ Maybe Format
247+ ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where
248+ labelOptic = #paramSchema % #format
249+ {-# INLINE labelOptic #-}
250+
251+instance
252+ ( a ~ Maybe Format, b ~ Maybe Format
253+ ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where
254+ labelOptic = #paramSchema % #format
255+ {-# INLINE labelOptic #-}
256+
257+-- #items
258+
259+instance
260+ ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
261+ , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
262+ ) => LabelOptic "items" A_Lens Header Header a b where
263+ labelOptic = #paramSchema % #items
264+ {-# INLINE labelOptic #-}
265+
266+instance
267+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
268+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
269+ ) => LabelOptic "items" A_Lens Schema Schema a b where
270+ labelOptic = #paramSchema % #items
271+ {-# INLINE labelOptic #-}
272+
273+instance
274+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
275+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
276+ ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
277+ labelOptic = #paramSchema % #items
278+ {-# INLINE labelOptic #-}
279+
280+instance
281+ ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
282+ , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
283+ ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where
284+ labelOptic = #paramSchema % #items
285+ {-# INLINE labelOptic #-}
286+
287+-- #maximum
288+
289+instance
290+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
291+ ) => LabelOptic "maximum" A_Lens Header Header a b where
292+ labelOptic = #paramSchema % #maximum
293+ {-# INLINE labelOptic #-}
294+
295+instance
296+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
297+ ) => LabelOptic "maximum" A_Lens Schema Schema a b where
298+ labelOptic = #paramSchema % #maximum
299+ {-# INLINE labelOptic #-}
300+
301+instance
302+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
303+ ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where
304+ labelOptic = #paramSchema % #maximum
305+ {-# INLINE labelOptic #-}
306+
307+instance
308+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
309+ ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
310+ labelOptic = #paramSchema % #maximum
311+ {-# INLINE labelOptic #-}
312+
313+-- #exclusiveMaximum
314+
315+instance
316+ ( a ~ Maybe Bool, b ~ Maybe Bool
317+ ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where
318+ labelOptic = #paramSchema % #exclusiveMaximum
319+ {-# INLINE labelOptic #-}
320+
321+instance
322+ ( a ~ Maybe Bool, b ~ Maybe Bool
323+ ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where
324+ labelOptic = #paramSchema % #exclusiveMaximum
325+ {-# INLINE labelOptic #-}
326+
327+instance
328+ ( a ~ Maybe Bool, b ~ Maybe Bool
329+ ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where
330+ labelOptic = #paramSchema % #exclusiveMaximum
331+ {-# INLINE labelOptic #-}
332+
333+instance
334+ ( a ~ Maybe Bool, b ~ Maybe Bool
335+ ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
336+ labelOptic = #paramSchema % #exclusiveMaximum
337+ {-# INLINE labelOptic #-}
338+
339+-- #minimum
340+
341+instance
342+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
343+ ) => LabelOptic "minimum" A_Lens Header Header a b where
344+ labelOptic = #paramSchema % #minimum
345+ {-# INLINE labelOptic #-}
346+
347+instance
348+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
349+ ) => LabelOptic "minimum" A_Lens Schema Schema a b where
350+ labelOptic = #paramSchema % #minimum
351+ {-# INLINE labelOptic #-}
352+
353+instance
354+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
355+ ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where
356+ labelOptic = #paramSchema % #minimum
357+ {-# INLINE labelOptic #-}
358+
359+instance
360+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
361+ ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
362+ labelOptic = #paramSchema % #minimum
363+ {-# INLINE labelOptic #-}
364+
365+-- #exclusiveMinimum
366+
367+instance
368+ ( a ~ Maybe Bool, b ~ Maybe Bool
369+ ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where
370+ labelOptic = #paramSchema % #exclusiveMinimum
371+ {-# INLINE labelOptic #-}
372+
373+instance
374+ ( a ~ Maybe Bool, b ~ Maybe Bool
375+ ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where
376+ labelOptic = #paramSchema % #exclusiveMinimum
377+ {-# INLINE labelOptic #-}
378+
379+instance
380+ ( a ~ Maybe Bool, b ~ Maybe Bool
381+ ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where
382+ labelOptic = #paramSchema % #exclusiveMinimum
383+ {-# INLINE labelOptic #-}
384+
385+instance
386+ ( a ~ Maybe Bool, b ~ Maybe Bool
387+ ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
388+ labelOptic = #paramSchema % #exclusiveMinimum
389+ {-# INLINE labelOptic #-}
390+
391+-- #maxLength
392+
393+instance
394+ ( a ~ Maybe Integer, b ~ Maybe Integer
395+ ) => LabelOptic "maxLength" A_Lens Header Header a b where
396+ labelOptic = #paramSchema % #maxLength
397+ {-# INLINE labelOptic #-}
398+
399+instance
400+ ( a ~ Maybe Integer, b ~ Maybe Integer
401+ ) => LabelOptic "maxLength" A_Lens Schema Schema a b where
402+ labelOptic = #paramSchema % #maxLength
403+ {-# INLINE labelOptic #-}
404+
405+instance
406+ ( a ~ Maybe Integer, b ~ Maybe Integer
407+ ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where
408+ labelOptic = #paramSchema % #maxLength
409+ {-# INLINE labelOptic #-}
410+
411+instance
412+ ( a ~ Maybe Integer, b ~ Maybe Integer
413+ ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
414+ labelOptic = #paramSchema % #maxLength
415+ {-# INLINE labelOptic #-}
416+
417+-- #minLength
418+
419+instance
420+ ( a ~ Maybe Integer, b ~ Maybe Integer
421+ ) => LabelOptic "minLength" A_Lens Header Header a b where
422+ labelOptic = #paramSchema % #minLength
423+ {-# INLINE labelOptic #-}
424+
425+instance
426+ ( a ~ Maybe Integer, b ~ Maybe Integer
427+ ) => LabelOptic "minLength" A_Lens Schema Schema a b where
428+ labelOptic = #paramSchema % #minLength
429+ {-# INLINE labelOptic #-}
430+
431+instance
432+ ( a ~ Maybe Integer, b ~ Maybe Integer
433+ ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where
434+ labelOptic = #paramSchema % #minLength
435+ {-# INLINE labelOptic #-}
436+
437+instance
438+ ( a ~ Maybe Integer, b ~ Maybe Integer
439+ ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
440+ labelOptic = #paramSchema % #minLength
441+ {-# INLINE labelOptic #-}
442+
443+-- #pattern
444+
445+instance
446+ ( a ~ Maybe Text, b ~ Maybe Text
447+ ) => LabelOptic "pattern" A_Lens Header Header a b where
448+ labelOptic = #paramSchema % #pattern
449+ {-# INLINE labelOptic #-}
450+
451+instance
452+ ( a ~ Maybe Text, b ~ Maybe Text
453+ ) => LabelOptic "pattern" A_Lens Schema Schema a b where
454+ labelOptic = #paramSchema % #pattern
455+ {-# INLINE labelOptic #-}
456+
457+instance
458+ ( a ~ Maybe Text, b ~ Maybe Text
459+ ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where
460+ labelOptic = #paramSchema % #pattern
461+ {-# INLINE labelOptic #-}
462+
463+instance
464+ ( a ~ Maybe Text, b ~ Maybe Text
465+ ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where
466+ labelOptic = #paramSchema % #pattern
467+ {-# INLINE labelOptic #-}
468+
469+-- #maxItems
470+
471+instance
472+ ( a ~ Maybe Integer, b ~ Maybe Integer
473+ ) => LabelOptic "maxItems" A_Lens Header Header a b where
474+ labelOptic = #paramSchema % #maxItems
475+ {-# INLINE labelOptic #-}
476+
477+instance
478+ ( a ~ Maybe Integer, b ~ Maybe Integer
479+ ) => LabelOptic "maxItems" A_Lens Schema Schema a b where
480+ labelOptic = #paramSchema % #maxItems
481+ {-# INLINE labelOptic #-}
482+
483+instance
484+ ( a ~ Maybe Integer, b ~ Maybe Integer
485+ ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where
486+ labelOptic = #paramSchema % #maxItems
487+ {-# INLINE labelOptic #-}
488+
489+instance
490+ ( a ~ Maybe Integer, b ~ Maybe Integer
491+ ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
492+ labelOptic = #paramSchema % #maxItems
493+ {-# INLINE labelOptic #-}
494+
495+-- #minItems
496+
497+instance
498+ ( a ~ Maybe Integer, b ~ Maybe Integer
499+ ) => LabelOptic "minItems" A_Lens Header Header a b where
500+ labelOptic = #paramSchema % #minItems
501+ {-# INLINE labelOptic #-}
502+
503+instance
504+ ( a ~ Maybe Integer, b ~ Maybe Integer
505+ ) => LabelOptic "minItems" A_Lens Schema Schema a b where
506+ labelOptic = #paramSchema % #minItems
507+ {-# INLINE labelOptic #-}
508+
509+instance
510+ ( a ~ Maybe Integer, b ~ Maybe Integer
511+ ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where
512+ labelOptic = #paramSchema % #minItems
513+ {-# INLINE labelOptic #-}
514+
515+instance
516+ ( a ~ Maybe Integer, b ~ Maybe Integer
517+ ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
518+ labelOptic = #paramSchema % #minItems
519+ {-# INLINE labelOptic #-}
520+
521+-- #uniqueItems
522+
523+instance
524+ ( a ~ Maybe Bool, b ~ Maybe Bool
525+ ) => LabelOptic "uniqueItems" A_Lens Header Header a b where
526+ labelOptic = #paramSchema % #uniqueItems
527+ {-# INLINE labelOptic #-}
528+
529+instance
530+ ( a ~ Maybe Bool, b ~ Maybe Bool
531+ ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where
532+ labelOptic = #paramSchema % #uniqueItems
533+ {-# INLINE labelOptic #-}
534+
535+instance
536+ ( a ~ Maybe Bool, b ~ Maybe Bool
537+ ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where
538+ labelOptic = #paramSchema % #uniqueItems
539+ {-# INLINE labelOptic #-}
540+
541+instance
542+ ( a ~ Maybe Bool, b ~ Maybe Bool
543+ ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
544+ labelOptic = #paramSchema % #uniqueItems
545+ {-# INLINE labelOptic #-}
546+
547+-- #enum
548+
549+instance
550+ ( a ~ Maybe [Value], b ~ Maybe [Value]
551+ ) => LabelOptic "enum" A_Lens Header Header a b where
552+ labelOptic = #paramSchema % #enum
553+ {-# INLINE labelOptic #-}
554+
555+instance
556+ ( a ~ Maybe [Value], b ~ Maybe [Value]
557+ ) => LabelOptic "enum" A_Lens Schema Schema a b where
558+ labelOptic = #paramSchema % #enum
559+ {-# INLINE labelOptic #-}
560+
561+instance
562+ ( a ~ Maybe [Value], b ~ Maybe [Value]
563+ ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where
564+ labelOptic = #paramSchema % #enum
565+ {-# INLINE labelOptic #-}
566+
567+instance
568+ ( a ~ Maybe [Value], b ~ Maybe [Value]
569+ ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where
570+ labelOptic = #paramSchema % #enum
571+ {-# INLINE labelOptic #-}
572+
573+-- #multipleOf
574+
575+instance
576+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
577+ ) => LabelOptic "multipleOf" A_Lens Header Header a b where
578+ labelOptic = #paramSchema % #multipleOf
579+ {-# INLINE labelOptic #-}
580+
581+instance
582+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
583+ ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where
584+ labelOptic = #paramSchema % #multipleOf
585+ {-# INLINE labelOptic #-}
586+
587+instance
588+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
589+ ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where
590+ labelOptic = #paramSchema % #multipleOf
591+ {-# INLINE labelOptic #-}
592+
593+instance
594+ ( a ~ Maybe Scientific, b ~ Maybe Scientific
595+ ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where
596+ labelOptic = #paramSchema % #multipleOf
597+ {-# INLINE labelOptic #-}
src/Data/Swagger/Schema.hs+11
@@ -17,8 +17,18 @@ module Data.Swagger.Schema (
1717 -- * Generic schema encoding
1818 genericDeclareNamedSchema,
1919 genericDeclareSchema,
20+ genericDeclareNamedSchemaNewtype,
21+ genericNameSchema,
22+
23+ -- ** 'Bounded' 'Integral'
2024 genericToNamedSchemaBoundedIntegral,
2125 toSchemaBoundedIntegral,
26+
27+ -- ** 'Bounded' 'Enum' key mappings
28+ declareSchemaBoundedEnumKeyMapping,
29+ toSchemaBoundedEnumKeyMapping,
30+
31+ -- ** Reusing 'ToParamSchema'
2232 paramSchemaToNamedSchema,
2333 paramSchemaToSchema,
2434
@@ -44,6 +54,7 @@ module Data.Swagger.Schema (
4454 -- * Generic encoding configuration
4555 SchemaOptions(..),
4656 defaultSchemaOptions,
57+ fromAesonOptions,
4758) where
4859
4960import Data.Swagger.Internal.Schema
src/Data/Swagger/Schema/Generator.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Data.Swagger.Schema.Generator where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Control.Lens.Operators
11+import Control.Monad (filterM)
12+import Data.Aeson
13+import Data.Aeson.Types
14+import qualified Data.HashMap.Strict.InsOrd as M
15+import Data.Maybe
16+import Data.Maybe
17+import Data.Proxy
18+import Data.Scientific
19+import qualified Data.Set as S
20+import Data.Swagger
21+import Data.Swagger.Declare
22+import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)
23+import qualified Data.Text as T
24+import qualified Data.Vector as V
25+import Test.QuickCheck (arbitrary)
26+import Test.QuickCheck.Gen
27+import Test.QuickCheck.Property
28+
29+-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30+-- and cannot be inferred.
31+schemaGen :: Definitions Schema -> Schema -> Gen Value
32+schemaGen _ schema
33+ | Just cases <- schema ^. paramSchema . enum_ = elements cases
34+schemaGen defns schema =
35+ case schema ^. type_ of
36+ Nothing ->
37+ case inferSchemaTypes schema of
38+ [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
39+ -- Gen is not MonadFail
40+ _ -> error "unable to infer schema type"
41+ Just SwaggerBoolean -> Bool <$> elements [True, False]
42+ Just SwaggerNull -> pure Null
43+ Just SwaggerNumber
44+ | Just min <- schema ^. minimum_
45+ , Just max <- schema ^. maximum_ ->
46+ Number . fromFloatDigits <$>
47+ choose (toRealFloat min, toRealFloat max :: Double)
48+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
49+ Just SwaggerInteger
50+ | Just min <- schema ^. minimum_
51+ , Just max <- schema ^. maximum_ ->
52+ Number . fromInteger <$>
53+ choose (truncate min, truncate max)
54+ | otherwise -> Number . fromInteger <$> arbitrary
55+ Just SwaggerArray
56+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
57+ | Just items <- schema ^. items ->
58+ case items of
59+ SwaggerItemsObject ref -> do
60+ size <- getSize
61+ let itemSchema = dereference defns ref
62+ minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
63+ maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
64+ arrayLength <- choose (minLength', max minLength' maxLength')
65+ generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
66+ return . Array $ V.fromList generatedArray
67+ SwaggerItemsArray refs ->
68+ let itemGens = schemaGen defns . dereference defns <$> refs
69+ in fmap (Array . V.fromList) $ sequence itemGens
70+ Just SwaggerString -> do
71+ size <- getSize
72+ let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
73+ let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
74+ length <- choose (minLength', max minLength' maxLength')
75+ str <- vectorOf length arbitrary
76+ return . String $ T.pack str
77+ Just SwaggerObject -> do
78+ size <- getSize
79+ let props = dereference defns <$> schema ^. properties
80+ reqKeys = S.fromList $ schema ^. required
81+ allKeys = S.fromList . M.keys $ schema ^. properties
82+ optionalKeys = allKeys S.\\ reqKeys
83+ minProps' = fromMaybe (length reqKeys) $
84+ fromInteger <$> schema ^. minProperties
85+ maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
86+ shuffledOptional <- shuffle $ S.toList optionalKeys
87+ numProps <- choose (minProps', max minProps' maxProps')
88+ let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
89+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
90+ let gens = schemaGen defns <$> presentProps
91+ additionalGens <- case schema ^. additionalProperties of
92+ Just (AdditionalPropertiesSchema addlSchema) -> do
93+ additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
94+ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
95+ _ -> return []
96+ x <- sequence $ gens <> additionalGens
97+ return . Object $ M.toHashMap x
98+ where
99+ dereference :: Definitions a -> Referenced a -> a
100+ dereference _ (Inline a) = a
101+ dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
102+
103+genValue :: (ToSchema a) => Proxy a -> Gen Value
104+genValue p =
105+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
106+ in schemaGen defs schema
107+
108+validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
109+validateFromJSON p = forAll (genValue p) $
110+ \val -> case parseEither parseJSON val of
111+ Right (_ :: a) -> succeeded
112+ Left err -> failed
113+ { reason = err
114+ }
src/Data/Swagger/Schema/Validation.hs+10−1
@@ -15,9 +15,18 @@ module Data.Swagger.Schema.Validation (
1515 -- $maybe
1616
1717 -- * JSON validation
18+
19+ ValidationError,
20+
21+ -- ** Using 'ToJSON' and 'ToSchema'
22+ validatePrettyToJSON,
1823 validateToJSON,
1924 validateToJSONWithPatternChecker,
20− ValidationError,
25+ renderValidationErrors,
26+
27+ -- ** Using 'Value' and 'Schema'
28+ validateJSON,
29+ validateJSONWithPatternChecker,
2130) where
2231
2332import Data.Swagger.Internal.Schema.Validation
src/Data/Swagger/SchemaOptions.hs+29
@@ -1,3 +1,4 @@
1+{-# LANGUAGE RecordWildCards #-}
12-- |
23-- Module: Data.Swagger.SchemaOptions
34-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -6,6 +7,8 @@
67-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
78module Data.Swagger.SchemaOptions where
89
10+import qualified Data.Aeson.Types as Aeson
11+
912-- | Options that specify how to encode your type to Swagger schema.
1013data SchemaOptions = SchemaOptions
1114 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
@@ -41,3 +44,29 @@ defaultSchemaOptions = SchemaOptions
4144 , unwrapUnaryRecords = False
4245 }
4346
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-ghc-8.0.yamldeleted−5
@@ -1,5 +0,0 @@
1−resolver: nightly-2016-05-29
2−packages:
3−- '.'
4−extra-deps:
5− - aeson-0.11.2.1
stack-lts-2.yamldeleted−22
@@ -1,22 +0,0 @@
1−flags: {}
2−packages:
3−- '.'
4−extra-deps:
5−- aeson-0.11.2.1
6−- attoparsec-0.13.1.0
7−- base-compat-0.9.1
8−- fail-4.9.0.0
9−- generics-sop-0.2.1.0
10−- insert-ordered-containers-0.1.0.1
11−- primitive-0.6.1.0
12−- QuickCheck-2.8.2
13−- tagged-0.8.4
14−- unordered-containers-0.2.7.0
15−resolver: lts-2.22
16−flags:
17− aeson:
18− old-locale: true
19− QuickCheck:
20− base3: false
21− base4: true
22− base4point8: false
stack.yaml+7−1
@@ -1,3 +1,9 @@
1−resolver: lts-8.0
1+resolver: lts-14.3
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
swagger2.cabal+84−48
@@ -1,11 +1,15 @@
1+cabal-version: >=1.10
12name: swagger2
2−version: 2.1.4.2
3+version: 2.5
4+
35synopsis: Swagger 2.0 data model
6+category: Web, Swagger
47description:
5− This library is inteded to be used for decoding and encoding Swagger 2.0 API
8+ This library is intended to be used for decoding and encoding Swagger 2.0 API
69 specifications as well as manipulating them.
710 .
811 The original Swagger 2.0 specification is available at http://swagger.io/specification/.
12+
913homepage: https://github.com/GetShopTV/swagger2
1014bug-reports: https://github.com/GetShopTV/swagger2/issues
1115license: BSD3
@@ -13,19 +17,22 @@ license-file: LICENSE
1317author: Nickolay Kudasov
1418maintainer: nickolay@getshoptv.com
1519copyright: (c) 2015-2016, GetShopTV
16−category: Web, Swagger
1720build-type: Custom
1821extra-source-files:
1922 README.md
2023 , CHANGELOG.md
2124 , examples/*.hs
2225 , include/overlapping-compat.h
23−cabal-version: >=1.10
24−tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1
26+tested-with:
27+ GHC ==8.0.2
28+ || ==8.2.2
29+ || ==8.4.4
30+ || ==8.6.5
31+ || ==8.8.1
2532
2633custom-setup
2734 setup-depends:
28− base, Cabal, cabal-doctest >=1.0.2 && <1.1
35+ base, Cabal, cabal-doctest >=1.0.6 && <1.1
2936
3037library
3138 hs-source-dirs: src
@@ -35,8 +42,10 @@ library
3542 Data.Swagger.Declare
3643 Data.Swagger.Lens
3744 Data.Swagger.Operation
45+ Data.Swagger.Optics
3846 Data.Swagger.ParamSchema
3947 Data.Swagger.Schema
48+ Data.Swagger.Schema.Generator
4049 Data.Swagger.Schema.Validation
4150 Data.Swagger.SchemaOptions
4251
@@ -48,62 +57,89 @@ library
4857 Data.Swagger.Internal.Utils
4958 Data.Swagger.Internal.AesonUtils
5059 Data.Swagger.Internal.TypeShape
51− build-depends: base >=4.7 && <4.11
52− , base-compat >=0.9.1 && <0.10
53− , aeson >=0.11.2.1
54− , bytestring
55− , containers
56− , hashable
57− , generics-sop >=0.2 && <0.4
58− , http-media
59− , insert-ordered-containers >=0.1.0.0 && <0.3
60− , lens
61− , mtl
62− , network
63− , scientific
64− , text
65− , template-haskell
66− , time
67− , transformers
68− , transformers-compat >= 0.3
69− , unordered-containers
70− , vector
71− , uuid-types >=1.0.2 && <1.1
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+
7296 default-language: Haskell2010
7397
7498test-suite spec
7599 type: exitcode-stdio-1.0
76100 hs-source-dirs: test
77101 main-is: Spec.hs
102+
103+ -- From library parat
78104 -- We need aeson's toEncoding for doctests too
79− build-depends: base
80− , base-compat
81− , aeson >=0.10.0.0
82− , aeson-qq
83− , bytestring
84− , containers
85− , hashable
86− , hspec
87− , insert-ordered-containers
88− , HUnit
89− , mtl
90− , QuickCheck >=2.8.2
91− , swagger2
92− , text
93− , time
94− , unordered-containers
95− , vector
96− , lens
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+
97134 other-modules:
98135 SpecCommon
99136 Data.SwaggerSpec
137+ Data.Swagger.CommonTestTypes
100138 Data.Swagger.ParamSchemaSpec
101139 Data.Swagger.SchemaSpec
102140 Data.Swagger.Schema.ValidationSpec
141+ Data.Swagger.Schema.GeneratorSpec
103142 default-language: Haskell2010
104− -- https://github.com/haskell/cabal/issues/3708
105− build-tool-depends:
106− hspec-discover:hspec-discover
107143
108144test-suite doctests
109145 -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
test/Data/Swagger/CommonTestTypes.hsnew file+679
@@ -0,0 +1,679 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Data.Swagger.CommonTestTypes where
6+
7+import Prelude ()
8+import Prelude.Compat
9+
10+import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)
11+import Data.Aeson.QQ.Simple
12+import Data.Aeson.Types (toJSONKeyText)
13+import Data.Char
14+import Data.Map (Map)
15+import Data.Proxy
16+import Data.Set (Set)
17+import qualified Data.Text as Text
18+import GHC.Generics
19+
20+import Data.Swagger
21+
22+-- ========================================================================
23+-- Unit type
24+-- ========================================================================
25+
26+data Unit = Unit deriving (Generic)
27+instance ToParamSchema Unit
28+instance ToSchema Unit
29+
30+unitSchemaJSON :: Value
31+unitSchemaJSON = [aesonQQ|
32+{
33+ "type": "string",
34+ "enum": ["Unit"]
35+}
36+|]
37+
38+-- ========================================================================
39+-- Color (enum)
40+-- ========================================================================
41+data Color
42+ = Red
43+ | Green
44+ | Blue
45+ deriving (Generic)
46+instance ToParamSchema Color
47+instance ToSchema Color
48+
49+colorSchemaJSON :: Value
50+colorSchemaJSON = [aesonQQ|
51+{
52+ "type": "string",
53+ "enum": ["Red", "Green", "Blue"]
54+}
55+|]
56+
57+-- ========================================================================
58+-- Shade (paramSchemaToNamedSchema)
59+-- ========================================================================
60+
61+data Shade = Dim | Bright deriving (Generic)
62+instance ToParamSchema Shade
63+
64+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
65+
66+shadeSchemaJSON :: Value
67+shadeSchemaJSON = [aesonQQ|
68+{
69+ "type": "string",
70+ "enum": ["Dim", "Bright"]
71+}
72+|]
73+
74+-- ========================================================================
75+-- Paint (record with bounded enum property)
76+-- ========================================================================
77+
78+newtype Paint = Paint { color :: Color }
79+ deriving (Generic)
80+instance ToSchema Paint
81+
82+paintSchemaJSON :: Value
83+paintSchemaJSON = [aesonQQ|
84+{
85+ "type": "object",
86+ "properties":
87+ {
88+ "color":
89+ {
90+ "$ref": "#/definitions/Color"
91+ }
92+ },
93+ "required": ["color"]
94+}
95+|]
96+
97+paintInlinedSchemaJSON :: Value
98+paintInlinedSchemaJSON = [aesonQQ|
99+{
100+ "type": "object",
101+ "properties":
102+ {
103+ "color":
104+ {
105+ "type": "string",
106+ "enum": ["Red", "Green", "Blue"]
107+ }
108+ },
109+ "required": ["color"]
110+}
111+|]
112+
113+-- ========================================================================
114+-- Status (constructorTagModifier)
115+-- ========================================================================
116+
117+data Status
118+ = StatusOk
119+ | StatusError
120+ deriving (Generic)
121+
122+instance ToParamSchema Status where
123+ toParamSchema = genericToParamSchema defaultSchemaOptions
124+ { constructorTagModifier = map toLower . drop (length "Status") }
125+instance ToSchema Status where
126+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
127+ { constructorTagModifier = map toLower . drop (length "Status") }
128+
129+statusSchemaJSON :: Value
130+statusSchemaJSON = [aesonQQ|
131+{
132+ "type": "string",
133+ "enum": ["ok", "error"]
134+}
135+|]
136+
137+-- ========================================================================
138+-- Email (newtype with unwrapUnaryRecords set to True)
139+-- ========================================================================
140+
141+newtype Email = Email { getEmail :: String }
142+ deriving (Generic)
143+instance ToParamSchema Email
144+instance ToSchema Email where
145+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
146+ { unwrapUnaryRecords = True }
147+
148+emailSchemaJSON :: Value
149+emailSchemaJSON = [aesonQQ|
150+{
151+ "type": "string"
152+}
153+|]
154+
155+-- ========================================================================
156+-- UserId (non-record newtype)
157+-- ========================================================================
158+
159+newtype UserId = UserId Integer
160+ deriving (Eq, Ord, Generic)
161+instance ToParamSchema UserId
162+instance ToSchema UserId
163+
164+userIdSchemaJSON :: Value
165+userIdSchemaJSON = [aesonQQ|
166+{
167+ "type": "integer"
168+}
169+|]
170+
171+-- ========================================================================
172+-- UserGroup (set newtype)
173+-- ========================================================================
174+
175+newtype UserGroup = UserGroup (Set UserId)
176+ deriving (Generic)
177+instance ToSchema UserGroup
178+
179+userGroupSchemaJSON :: Value
180+userGroupSchemaJSON = [aesonQQ|
181+{
182+ "type": "array",
183+ "items": { "$ref": "#/definitions/UserId" },
184+ "uniqueItems": true
185+}
186+|]
187+
188+-- ========================================================================
189+-- Person (simple record with optional fields)
190+-- ========================================================================
191+data Person = Person
192+ { name :: String
193+ , phone :: Integer
194+ , email :: Maybe String
195+ } deriving (Generic)
196+
197+instance ToSchema Person
198+
199+personSchemaJSON :: Value
200+personSchemaJSON = [aesonQQ|
201+{
202+ "type": "object",
203+ "properties":
204+ {
205+ "name": { "type": "string" },
206+ "phone": { "type": "integer" },
207+ "email": { "type": "string" }
208+ },
209+ "required": ["name", "phone"]
210+}
211+|]
212+
213+-- ========================================================================
214+-- Player (record newtype)
215+-- ========================================================================
216+
217+newtype Player = Player
218+ { position :: Point
219+ } deriving (Generic)
220+instance ToSchema Player
221+
222+playerSchemaJSON :: Value
223+playerSchemaJSON = [aesonQQ|
224+{
225+ "type": "object",
226+ "properties":
227+ {
228+ "position":
229+ {
230+ "$ref": "#/definitions/Point"
231+ }
232+ },
233+ "required": ["position"]
234+}
235+|]
236+
237+newtype Players = Players [Inlined Player]
238+ deriving (Generic)
239+instance ToSchema Players
240+
241+playersSchemaJSON :: Value
242+playersSchemaJSON = [aesonQQ|
243+{
244+ "type": "array",
245+ "items":
246+ {
247+ "type": "object",
248+ "properties":
249+ {
250+ "position":
251+ {
252+ "$ref": "#/definitions/Point"
253+ }
254+ },
255+ "required": ["position"]
256+ }
257+}
258+|]
259+
260+-- ========================================================================
261+-- Character (sum type with ref and record in alternative)
262+-- ========================================================================
263+
264+data Character
265+ = PC Player
266+ | NPC { npcName :: String, npcPosition :: Point }
267+ deriving (Generic)
268+instance ToSchema Character
269+
270+characterSchemaJSON :: Value
271+characterSchemaJSON = [aesonQQ|
272+{
273+ "type": "object",
274+ "properties":
275+ {
276+ "PC": { "$ref": "#/definitions/Player" },
277+ "NPC":
278+ {
279+ "type": "object",
280+ "properties":
281+ {
282+ "npcName": { "type": "string" },
283+ "npcPosition": { "$ref": "#/definitions/Point" }
284+ },
285+ "required": ["npcName", "npcPosition"]
286+ }
287+ },
288+ "maxProperties": 1,
289+ "minProperties": 1
290+}
291+|]
292+
293+characterInlinedSchemaJSON :: Value
294+characterInlinedSchemaJSON = [aesonQQ|
295+{
296+ "type": "object",
297+ "properties":
298+ {
299+ "PC":
300+ {
301+ "type": "object",
302+ "properties":
303+ {
304+ "position":
305+ {
306+ "type": "object",
307+ "properties":
308+ {
309+ "x": { "type": "number", "format": "double" },
310+ "y": { "type": "number", "format": "double" }
311+ },
312+ "required": ["x", "y"]
313+ }
314+ },
315+ "required": ["position"]
316+ },
317+ "NPC":
318+ {
319+ "type": "object",
320+ "properties":
321+ {
322+ "npcName": { "type": "string" },
323+ "npcPosition":
324+ {
325+ "type": "object",
326+ "properties":
327+ {
328+ "x": { "type": "number", "format": "double" },
329+ "y": { "type": "number", "format": "double" }
330+ },
331+ "required": ["x", "y"]
332+ }
333+ },
334+ "required": ["npcName", "npcPosition"]
335+ }
336+ },
337+ "maxProperties": 1,
338+ "minProperties": 1
339+}
340+|]
341+
342+characterInlinedPlayerSchemaJSON :: Value
343+characterInlinedPlayerSchemaJSON = [aesonQQ|
344+{
345+ "type": "object",
346+ "properties":
347+ {
348+ "PC":
349+ {
350+ "type": "object",
351+ "properties":
352+ {
353+ "position":
354+ {
355+ "$ref": "#/definitions/Point"
356+ }
357+ },
358+ "required": ["position"]
359+ },
360+ "NPC":
361+ {
362+ "type": "object",
363+ "properties":
364+ {
365+ "npcName": { "type": "string" },
366+ "npcPosition": { "$ref": "#/definitions/Point" }
367+ },
368+ "required": ["npcName", "npcPosition"]
369+ }
370+ },
371+ "maxProperties": 1,
372+ "minProperties": 1
373+}
374+|]
375+
376+-- ========================================================================
377+-- ISPair (non-record product data type)
378+-- ========================================================================
379+data ISPair = ISPair Integer String
380+ deriving (Generic)
381+
382+instance ToSchema ISPair
383+
384+ispairSchemaJSON :: Value
385+ispairSchemaJSON = [aesonQQ|
386+{
387+ "type": "array",
388+ "items":
389+ [
390+ { "type": "integer" },
391+ { "type": "string" }
392+ ],
393+ "minItems": 2,
394+ "maxItems": 2
395+}
396+|]
397+
398+-- ========================================================================
399+-- Point (record data type with custom fieldLabelModifier)
400+-- ========================================================================
401+
402+data Point = Point
403+ { pointX :: Double
404+ , pointY :: Double
405+ } deriving (Generic)
406+
407+instance ToSchema Point where
408+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
409+ { fieldLabelModifier = map toLower . drop (length "point") }
410+
411+pointSchemaJSON :: Value
412+pointSchemaJSON = [aesonQQ|
413+{
414+ "type": "object",
415+ "properties":
416+ {
417+ "x": { "type": "number", "format": "double" },
418+ "y": { "type": "number", "format": "double" }
419+ },
420+ "required": ["x", "y"]
421+}
422+|]
423+
424+-- ========================================================================
425+-- Point (record data type with multiple fields)
426+-- ========================================================================
427+
428+data Point5 = Point5
429+ { point5X :: Double
430+ , point5Y :: Double
431+ , point5Z :: Double
432+ , point5U :: Double
433+ , point5V :: Double -- 5 dimensional!
434+ } deriving (Generic)
435+
436+instance ToSchema Point5 where
437+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
438+ { fieldLabelModifier = map toLower . drop (length "point5") }
439+
440+point5SchemaJSON :: Value
441+point5SchemaJSON = [aesonQQ|
442+{
443+ "type": "object",
444+ "properties":
445+ {
446+ "x": { "type": "number", "format": "double" },
447+ "y": { "type": "number", "format": "double" },
448+ "z": { "type": "number", "format": "double" },
449+ "u": { "type": "number", "format": "double" },
450+ "v": { "type": "number", "format": "double" }
451+ },
452+ "required": ["x", "y", "z", "u", "v"]
453+}
454+|]
455+
456+point5Properties :: [String]
457+point5Properties = ["x", "y", "z", "u", "v"]
458+
459+-- ========================================================================
460+-- MyRoseTree (custom datatypeNameModifier)
461+-- ========================================================================
462+
463+data MyRoseTree = MyRoseTree
464+ { root :: String
465+ , trees :: [MyRoseTree]
466+ } deriving (Generic)
467+
468+instance ToSchema MyRoseTree where
469+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
470+ { datatypeNameModifier = drop (length "My") }
471+
472+myRoseTreeSchemaJSON :: Value
473+myRoseTreeSchemaJSON = [aesonQQ|
474+{
475+ "type": "object",
476+ "properties":
477+ {
478+ "root": { "type": "string" },
479+ "trees":
480+ {
481+ "type": "array",
482+ "items":
483+ {
484+ "$ref": "#/definitions/RoseTree"
485+ }
486+ }
487+ },
488+ "required": ["root", "trees"]
489+}
490+|]
491+
492+data MyRoseTree' = MyRoseTree'
493+ { root' :: String
494+ , trees' :: [MyRoseTree']
495+ } deriving (Generic)
496+
497+instance ToSchema MyRoseTree' where
498+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
499+ { datatypeNameModifier = map toLower }
500+
501+myRoseTreeSchemaJSON' :: Value
502+myRoseTreeSchemaJSON' = [aesonQQ|
503+{
504+ "type": "object",
505+ "properties":
506+ {
507+ "root'": { "type": "string" },
508+ "trees'":
509+ {
510+ "type": "array",
511+ "items":
512+ {
513+ "$ref": "#/definitions/myrosetree'"
514+ }
515+ }
516+ },
517+ "required": ["root'", "trees'"]
518+}
519+|]
520+
521+-- ========================================================================
522+-- Inlined (newtype for inlining schemas)
523+-- ========================================================================
524+
525+newtype Inlined a = Inlined { getInlined :: a }
526+
527+instance ToSchema a => ToSchema (Inlined a) where
528+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
529+ where
530+ unname (NamedSchema _ s) = NamedSchema Nothing s
531+
532+-- ========================================================================
533+-- Light (sum type with unwrapUnaryRecords)
534+-- ========================================================================
535+
536+data Light
537+ = NoLight
538+ | LightFreq Double
539+ | LightColor Color
540+ | LightWaveLength { waveLength :: Double }
541+ deriving (Generic)
542+
543+instance ToSchema Light where
544+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
545+ { unwrapUnaryRecords = True }
546+
547+lightSchemaJSON :: Value
548+lightSchemaJSON = [aesonQQ|
549+{
550+ "type": "object",
551+ "properties":
552+ {
553+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
554+ "LightFreq": { "type": "number", "format": "double" },
555+ "LightColor": { "$ref": "#/definitions/Color" },
556+ "LightWaveLength": { "type": "number", "format": "double" }
557+ },
558+ "maxProperties": 1,
559+ "minProperties": 1
560+}
561+|]
562+
563+lightInlinedSchemaJSON :: Value
564+lightInlinedSchemaJSON = [aesonQQ|
565+{
566+ "type": "object",
567+ "properties":
568+ {
569+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
570+ "LightFreq": { "type": "number", "format": "double" },
571+ "LightColor":
572+ {
573+ "type": "string",
574+ "enum": ["Red", "Green", "Blue"]
575+ },
576+ "LightWaveLength": { "type": "number", "format": "double" }
577+ },
578+ "maxProperties": 1,
579+ "minProperties": 1
580+}
581+|]
582+
583+-- ========================================================================
584+-- ResourceId (series of newtypes)
585+-- ========================================================================
586+
587+newtype Id = Id String deriving (Generic)
588+instance ToSchema Id
589+
590+newtype ResourceId = ResourceId Id deriving (Generic)
591+instance ToSchema ResourceId
592+
593+-- ========================================================================
594+-- ButtonImages (bounded enum key mapping)
595+-- ========================================================================
596+
597+data ButtonState = Neutral | Focus | Active | Hover | Disabled
598+ deriving (Show, Bounded, Enum, Generic)
599+
600+instance ToJSON ButtonState
601+instance ToSchema ButtonState
602+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
603+
604+type ImageUrl = Text.Text
605+
606+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
607+ deriving (Generic)
608+
609+instance ToJSON ButtonImages where
610+ toJSON = toJSON . getButtonImages
611+
612+instance ToSchema ButtonImages where
613+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
614+ declareSchemaBoundedEnumKeyMapping
615+
616+buttonImagesSchemaJSON :: Value
617+buttonImagesSchemaJSON = [aesonQQ|
618+{
619+ "type": "object",
620+ "properties":
621+ {
622+ "Neutral": { "type": "string" },
623+ "Focus": { "type": "string" },
624+ "Active": { "type": "string" },
625+ "Hover": { "type": "string" },
626+ "Disabled": { "type": "string" }
627+ }
628+}
629+|]
630+
631+-- ========================================================================
632+-- SingleMaybeField (single field data with optional field)
633+-- ========================================================================
634+
635+data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
636+ deriving (Show, Generic)
637+
638+instance ToJSON SingleMaybeField
639+instance ToSchema SingleMaybeField
640+
641+singleMaybeFieldSchemaJSON :: Value
642+singleMaybeFieldSchemaJSON = [aesonQQ|
643+{
644+ "type": "object",
645+ "properties":
646+ {
647+ "singleMaybeField": { "type": "string" }
648+ }
649+}
650+|]
651+
652+
653+-- ========================================================================
654+-- TimeOfDay
655+-- ========================================================================
656+data TimeOfDay
657+ = Int
658+ | Pico
659+ deriving (Generic)
660+instance ToSchema TimeOfDay
661+instance ToParamSchema TimeOfDay
662+
663+
664+timeOfDaySchemaJSON :: Value
665+timeOfDaySchemaJSON = [aesonQQ|
666+{
667+ "example": "12:33:15",
668+ "type": "string",
669+ "format": "hh:MM:ss"
670+}
671+|]
672+
673+timeOfDayParamSchemaJSON :: Value
674+timeOfDayParamSchemaJSON = [aesonQQ|
675+{
676+ "type": "string",
677+ "format": "hh:MM:ss"
678+}
679+|]
test/Data/Swagger/ParamSchemaSpec.hs+7−83
@@ -3,10 +3,11 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE QuasiQuotes #-}
6+{-# LANGUAGE OverloadedStrings #-}
67module Data.Swagger.ParamSchemaSpec where
78
89import Data.Aeson
9−import Data.Aeson.QQ
10+import Data.Aeson.QQ.Simple
1011import Data.Char
1112import Data.Proxy
1213import GHC.Generics
@@ -14,8 +15,12 @@ import GHC.Generics
1415import Data.Swagger
1516import Data.Swagger.Internal (SwaggerKind(..))
1617
18+import Data.Swagger.CommonTestTypes
1719import SpecCommon
1820import Test.Hspec
21+import Data.Time.LocalTime
22+
23+import qualified Data.HashMap.Strict as HM
1924
2025checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
2126checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
@@ -29,88 +34,7 @@ spec = do
2934 context "Unary records" $ do
3035 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
3136 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
3238
3339main :: IO ()
3440main = hspec spec
35−
36−-- ========================================================================
37−-- Unit type
38−-- ========================================================================
39−
40−data Unit = Unit deriving (Generic)
41−instance ToParamSchema Unit
42−
43−unitSchemaJSON :: Value
44−unitSchemaJSON = [aesonQQ|
45−{
46− "type": "string",
47− "enum": ["Unit"]
48−}
49−|]
50−
51−-- ========================================================================
52−-- Color (enum)
53−-- ========================================================================
54−data Color
55− = Red
56− | Green
57− | Blue
58− deriving (Generic)
59−instance ToParamSchema Color
60−
61−colorSchemaJSON :: Value
62−colorSchemaJSON = [aesonQQ|
63−{
64− "type": "string",
65− "enum": ["Red", "Green", "Blue"]
66−}
67−|]
68−
69−-- ========================================================================
70−-- Status (constructorTagModifier)
71−-- ========================================================================
72−
73−data Status = StatusOk | StatusError deriving (Generic)
74−
75−instance ToParamSchema Status where
76− toParamSchema = genericToParamSchema defaultSchemaOptions
77− { constructorTagModifier = map toLower . drop (length "Status") }
78−
79−statusSchemaJSON :: Value
80−statusSchemaJSON = [aesonQQ|
81−{
82− "type": "string",
83− "enum": ["ok", "error"]
84−}
85−|]
86−
87−-- ========================================================================
88−-- Email (newtype with unwrapUnaryRecords set to True)
89−-- ========================================================================
90−
91−newtype Email = Email { getEmail :: String }
92− deriving (Generic)
93−instance ToParamSchema Email
94−
95−emailSchemaJSON :: Value
96−emailSchemaJSON = [aesonQQ|
97−{
98− "type": "string"
99−}
100−|]
101−
102−-- ========================================================================
103−-- UserId (non-record newtype)
104−-- ========================================================================
105−
106−newtype UserId = UserId Integer
107− deriving (Generic)
108−instance ToParamSchema UserId
109−
110−userIdSchemaJSON :: Value
111−userIdSchemaJSON = [aesonQQ|
112−{
113− "type": "integer"
114−}
115−|]
116−
test/Data/Swagger/Schema/GeneratorSpec.hsnew file+168
@@ -0,0 +1,168 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE PackageImports #-}
4+module Data.Swagger.Schema.GeneratorSpec where
5+
6+import Prelude ()
7+import Prelude.Compat
8+
9+import Data.Swagger
10+import Data.Swagger.Schema.Generator
11+
12+import Control.Lens.Operators
13+import Data.Aeson
14+import Data.Hashable (Hashable)
15+import Data.HashMap.Strict (HashMap)
16+import qualified Data.HashMap.Strict as HashMap
17+import "unordered-containers" Data.HashSet (HashSet)
18+import qualified "unordered-containers" Data.HashSet as HashSet
19+import Data.Int
20+import Data.IntMap (IntMap)
21+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
22+import Data.Map (Map, fromList)
23+import Data.Monoid (mempty)
24+import Data.Proxy
25+import Data.Proxy
26+import Data.Set (Set)
27+import qualified Data.Text as T
28+import qualified Data.Text.Lazy as TL
29+import Data.Time
30+import Data.Version (Version)
31+import Data.Word
32+import GHC.Generics
33+
34+import Test.Hspec
35+import Test.Hspec.QuickCheck
36+import Test.QuickCheck
37+
38+shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
39+shouldValidate = validateFromJSON
40+
41+
42+shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
43+shouldNotValidate = expectFailure . shouldValidate
44+
45+
46+spec :: Spec
47+spec = do
48+ describe "FromJSON validation" $ do
49+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
50+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)
51+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)
52+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)
53+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)
54+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
55+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
56+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
57+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
58+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
59+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)
60+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
61+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
62+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
63+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
64+ prop "String" $ shouldValidate (Proxy :: Proxy String)
65+ prop "()" $ shouldValidate (Proxy :: Proxy ())
66+-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
67+-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
68+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
69+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
70+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71+ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
72+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
73+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
74+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
75+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
76+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
77+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
78+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
79+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
80+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
81+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
82+ prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
83+ prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
84+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)
85+ prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
86+ prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
87+ prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
88+ describe "Invalid FromJSON validation" $ do
89+ prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
90+ prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
91+ prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
92+ prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
93+
94+-- =============================
95+-- Data types and bunk instances
96+-- =============================
97+
98+data WrongType = WrongType Bool
99+
100+instance FromJSON WrongType where
101+ parseJSON = withBool "WrongType" $ return . WrongType
102+
103+instance ToSchema WrongType where
104+ declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105+ mempty
106+ & type_ ?~ SwaggerObject
107+
108+
109+data MissingRequired = MissingRequired
110+ { propA :: String
111+ , propB :: Bool
112+ }
113+
114+instance FromJSON MissingRequired where
115+ parseJSON = withObject "MissingRequired" $ \o ->
116+ MissingRequired
117+ <$> o .: "propA"
118+ <*> o .: "propB"
119+
120+instance ToSchema MissingRequired where
121+ declareNamedSchema _ = do
122+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)
123+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124+ return . NamedSchema (Just "MissingRequired") $
125+ mempty
126+ & type_ ?~ SwaggerObject
127+ & properties .~ [("propA", stringSchema)
128+ ,("propB", boolSchema)
129+ ]
130+ & required .~ ["propA"]
131+
132+data MissingProperty = MissingProperty
133+ { propC :: String
134+ , propD :: Bool
135+ }
136+
137+instance FromJSON MissingProperty where
138+ parseJSON = withObject "MissingProperty" $ \o ->
139+ MissingProperty
140+ <$> o .: "propC"
141+ <*> o .: "propD"
142+
143+instance ToSchema MissingProperty where
144+ declareNamedSchema _ = do
145+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146+ return . NamedSchema (Just "MissingProperty") $
147+ mempty
148+ & type_ ?~ SwaggerObject
149+ & properties .~ [("propC", stringSchema)]
150+ & required .~ ["propC"]
151+
152+data WrongPropType = WrongPropType
153+ { propE :: String
154+ }
155+
156+instance FromJSON WrongPropType where
157+ parseJSON = withObject "WrongPropType" $ \o ->
158+ WrongPropType
159+ <$> o .: "propE"
160+
161+instance ToSchema WrongPropType where
162+ declareNamedSchema _ = do
163+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164+ return . NamedSchema (Just "WrongPropType") $
165+ mempty
166+ & type_ ?~ SwaggerObject
167+ & properties .~ [("propE", boolSchema)]
168+ & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hs+130−48
@@ -1,37 +1,50 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE PackageImports #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
46{-# OPTIONS_GHC -fno-warn-orphans #-}
57module Data.Swagger.Schema.ValidationSpec where
68
7−import Control.Applicative
8−import Data.Aeson
9−import Data.Aeson.Types
10−import Data.Int
11−import Data.IntMap (IntMap)
12−import Data.Hashable (Hashable)
13−import "unordered-containers" Data.HashSet (HashSet)
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)
1417import qualified "unordered-containers" Data.HashSet as HashSet
15−import Data.HashMap.Strict (HashMap)
16−import qualified Data.HashMap.Strict as HashMap
17−import Data.Map (Map)
18−import Data.Proxy
19−import Data.Time
20−import qualified Data.Text as T
21−import qualified Data.Text.Lazy as TL
22−import Data.Set (Set)
23−import Data.Word
24−import GHC.Generics
25−
26−import Data.Swagger
27−
28−import Test.Hspec
29−import Test.Hspec.QuickCheck
30−import Test.QuickCheck
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 ()
3139
3240shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
3341shouldValidate _ x = validateToJSON x == []
3442
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+
3548spec :: Spec
3649spec = do
3750 describe "Validation" $ do
@@ -60,6 +73,7 @@ spec = do
6073 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
6174 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
6275 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
76+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
6377 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
6478 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
6579 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
@@ -69,6 +83,7 @@ spec = do
6983 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
7084 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
7185 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
86+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)
7287 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
7388 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
7489 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
@@ -77,6 +92,16 @@ spec = do
7792 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
7893 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
7994 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
80105
81106main :: IO ()
82107main = hspec spec
@@ -96,6 +121,13 @@ instance ToSchema Person
96121instance Arbitrary Person where
97122 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
98123
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+
99131-- ========================================================================
100132-- Color (enum)
101133-- ========================================================================
@@ -107,6 +139,11 @@ instance ToSchema Color
107139instance Arbitrary Color where
108140 arbitrary = arbitraryBoundedEnum
109141
142+invalidColorToJSON :: Color -> Value
143+invalidColorToJSON Red = toJSON "red"
144+invalidColorToJSON Green = toJSON "green"
145+invalidColorToJSON Blue = toJSON "blue"
146+
110147-- ========================================================================
111148-- Paint (record with bounded enum property)
112149-- ========================================================================
@@ -120,6 +157,9 @@ instance ToSchema Paint
120157instance Arbitrary Paint where
121158 arbitrary = Paint <$> arbitrary
122159
160+invalidPaintToJSON :: Paint -> Value
161+invalidPaintToJSON = toJSON . color
162+
123163-- ========================================================================
124164-- MyRoseTree (custom datatypeNameModifier)
125165-- ========================================================================
@@ -161,36 +201,78 @@ instance Arbitrary Light where
161201 , LightColor <$> arbitrary
162202 ]
163203
164−-- Arbitrary instances for common types
204+invalidLightToJSON :: Light -> Value
205+invalidLightToJSON = genericToJSON defaultOptions
165206
166−instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
167− arbitrary = HashMap.fromList <$> arbitrary
207+-- ========================================================================
208+-- ButtonImages (bounded enum key mapping)
209+-- ========================================================================
168210
169−instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where
170− arbitrary = HashSet.fromList <$> arbitrary
211+data ButtonState = Neutral | Focus | Active | Hover | Disabled
212+ deriving (Show, Eq, Ord, Bounded, Enum, Generic)
213+
214+instance ToJSON ButtonState
215+instance ToSchema ButtonState
216+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
217+
218+instance Arbitrary ButtonState where
219+ arbitrary = arbitraryBoundedEnum
220+
221+type ImageUrl = T.Text
222+
223+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
224+ deriving (Show, Generic)
171225
172−instance Arbitrary T.Text where
173− arbitrary = T.pack <$> arbitrary
226+instance ToJSON ButtonImages where
227+ toJSON = toJSON . getButtonImages
174228
175−instance Arbitrary TL.Text where
176− arbitrary = TL.pack <$> arbitrary
229+instance ToSchema ButtonImages where
230+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
231+ declareSchemaBoundedEnumKeyMapping
177232
178−instance Arbitrary Day where
179− arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary
233+invalidButtonImagesToJSON :: ButtonImages -> Value
234+invalidButtonImagesToJSON = genericToJSON defaultOptions
180235
181−instance Arbitrary LocalTime where
182− arbitrary = LocalTime
183− <$> arbitrary
184− <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))
236+instance Arbitrary ButtonImages where
237+ arbitrary = ButtonImages <$> arbitrary
238+
239+-- ========================================================================
240+-- FreeForm (wraps a raw JSON Value)
241+-- ========================================================================
242+
243+data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
244+ deriving (Show, Generic)
245+
246+instance ToJSON FreeForm where
247+ toJSON = toJSON . jsonContent
248+
249+instance ToSchema FreeForm where
250+ declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
251+ & type_ ?~ SwaggerObject
252+ & additionalProperties ?~ AdditionalPropertiesAllowed True
253+
254+instance Arbitrary FreeForm where
255+ arbitrary = (FreeForm . fromList) <$> genObj
256+ where
257+ genObj = listOf $ do
258+ k <- arbitrary
259+ v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
260+ pure (k, v)
185261
186262instance Eq ZonedTime where
187263 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
188264
189−instance Arbitrary ZonedTime where
190− arbitrary = ZonedTime
191− <$> arbitrary
192− <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))
193−
194−instance Arbitrary UTCTime where
195− arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
265+-- ========================================================================
266+-- Arbitrary instance for Data.Aeson.Value
267+-- ========================================================================
196268
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+12−547
@@ -8,21 +8,22 @@ import Prelude ()
88import Prelude.Compat
99
1010import Control.Lens ((^.))
11−import Data.Aeson
12−import Data.Aeson.QQ
13−import Data.Char
11+import Data.Aeson (Value)
1412import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
1513import Data.Proxy
1614import Data.Set (Set)
1715import qualified Data.Text as Text
18−import GHC.Generics
1916
2017import Data.Swagger
2118import Data.Swagger.Declare
2219
20+import Data.Swagger.CommonTestTypes
2321import SpecCommon
2422import Test.Hspec
2523
24+import qualified Data.HashMap.Strict as HM
25+import Data.Time.LocalTime
26+
2627checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
2728checkToSchema proxy js = toSchema proxy <=> js
2829
@@ -76,8 +77,10 @@ spec = do
7677 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
7778 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
7879 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80+ context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
7981 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
8082 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
8184 context "Sum types" $ do
8285 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
8386 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -93,6 +96,7 @@ spec = do
9396 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
9497 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
9598 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99+ context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
96100 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
97101 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
98102 describe "Inlining Schemas" $ do
@@ -101,549 +105,10 @@ spec = do
101105 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
102106 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
103107 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
104112
105113main :: IO ()
106114main = hspec spec
107−
108−-- ========================================================================
109−-- Person (simple record with optional fields)
110−-- ========================================================================
111−data Person = Person
112− { name :: String
113− , phone :: Integer
114− , email :: Maybe String
115− } deriving (Generic)
116−
117−instance ToSchema Person
118−
119−personSchemaJSON :: Value
120−personSchemaJSON = [aesonQQ|
121−{
122− "type": "object",
123− "properties":
124− {
125− "name": { "type": "string" },
126− "phone": { "type": "integer" },
127− "email": { "type": "string" }
128− },
129− "required": ["name", "phone"]
130−}
131−|]
132−
133−-- ========================================================================
134−-- ISPair (non-record product data type)
135−-- ========================================================================
136−data ISPair = ISPair Integer String
137− deriving (Generic)
138−
139−instance ToSchema ISPair
140−
141−ispairSchemaJSON :: Value
142−ispairSchemaJSON = [aesonQQ|
143−{
144− "type": "array",
145− "items":
146− [
147− { "type": "integer" },
148− { "type": "string" }
149− ],
150− "minItems": 2,
151− "maxItems": 2
152−}
153−|]
154−
155−-- ========================================================================
156−-- Point (record data type with custom fieldLabelModifier)
157−-- ========================================================================
158−
159−data Point = Point
160− { pointX :: Double
161− , pointY :: Double
162− } deriving (Generic)
163−
164−instance ToSchema Point where
165− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
166− { fieldLabelModifier = map toLower . drop (length "point") }
167−
168−pointSchemaJSON :: Value
169−pointSchemaJSON = [aesonQQ|
170−{
171− "type": "object",
172− "properties":
173− {
174− "x": { "type": "number", "format": "double" },
175− "y": { "type": "number", "format": "double" }
176− },
177− "required": ["x", "y"]
178−}
179−|]
180−
181−-- ========================================================================
182−-- Point (record data type with multiple fields)
183−-- ========================================================================
184−
185−data Point5 = Point5
186− { point5X :: Double
187− , point5Y :: Double
188− , point5Z :: Double
189− , point5U :: Double
190− , point5V :: Double -- 5 dimensional!
191− } deriving (Generic)
192−
193−instance ToSchema Point5 where
194− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
195− { fieldLabelModifier = map toLower . drop (length "point5") }
196−
197−point5SchemaJSON :: Value
198−point5SchemaJSON = [aesonQQ|
199−{
200− "type": "object",
201− "properties":
202− {
203− "x": { "type": "number", "format": "double" },
204− "y": { "type": "number", "format": "double" },
205− "z": { "type": "number", "format": "double" },
206− "u": { "type": "number", "format": "double" },
207− "v": { "type": "number", "format": "double" }
208− },
209− "required": ["x", "y", "z", "u", "v"]
210−}
211−|]
212−
213−point5Properties :: [String]
214−point5Properties = ["x", "y", "z", "u", "v"]
215−
216−-- ========================================================================
217−-- Color (enum)
218−-- ========================================================================
219−data Color
220− = Red
221− | Green
222− | Blue
223− deriving (Generic)
224−instance ToSchema Color
225−
226−colorSchemaJSON :: Value
227−colorSchemaJSON = [aesonQQ|
228−{
229− "type": "string",
230− "enum": ["Red", "Green", "Blue"]
231−}
232−|]
233−
234−-- ========================================================================
235−-- Shade (paramSchemaToNamedSchema)
236−-- ========================================================================
237−
238−data Shade = Dim | Bright deriving (Generic)
239−instance ToParamSchema Shade
240−
241−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
242−
243−shadeSchemaJSON :: Value
244−shadeSchemaJSON = [aesonQQ|
245−{
246− "type": "string",
247− "enum": ["Dim", "Bright"]
248−}
249−|]
250−
251−-- ========================================================================
252−-- Paint (record with bounded enum property)
253−-- ========================================================================
254−
255−newtype Paint = Paint { color :: Color }
256− deriving (Generic)
257−instance ToSchema Paint
258−
259−paintSchemaJSON :: Value
260−paintSchemaJSON = [aesonQQ|
261−{
262− "type": "object",
263− "properties":
264− {
265− "color":
266− {
267− "$ref": "#/definitions/Color"
268− }
269− },
270− "required": ["color"]
271−}
272−|]
273−
274−paintInlinedSchemaJSON :: Value
275−paintInlinedSchemaJSON = [aesonQQ|
276−{
277− "type": "object",
278− "properties":
279− {
280− "color":
281− {
282− "type": "string",
283− "enum": ["Red", "Green", "Blue"]
284− }
285− },
286− "required": ["color"]
287−}
288−|]
289−
290−-- ========================================================================
291−-- Email (newtype with unwrapUnaryRecords set to True)
292−-- ========================================================================
293−
294−newtype Email = Email { getEmail :: String }
295− deriving (Generic)
296−
297−instance ToSchema Email where
298− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
299− { unwrapUnaryRecords = True }
300−
301−emailSchemaJSON :: Value
302−emailSchemaJSON = [aesonQQ|
303−{
304− "type": "string"
305−}
306−|]
307−
308−-- ========================================================================
309−-- UserId (non-record newtype)
310−-- ========================================================================
311−
312−newtype UserId = UserId Integer
313− deriving (Eq, Ord, Generic)
314−instance ToSchema UserId
315−
316−userIdSchemaJSON :: Value
317−userIdSchemaJSON = [aesonQQ|
318−{
319− "type": "integer"
320−}
321−|]
322−
323−-- ========================================================================
324−-- UserGroup (set newtype)
325−-- ========================================================================
326−
327−newtype UserGroup = UserGroup (Set UserId)
328− deriving (Generic)
329−instance ToSchema UserGroup
330−
331−userGroupSchemaJSON :: Value
332−userGroupSchemaJSON = [aesonQQ|
333−{
334− "type": "array",
335− "items": { "$ref": "#/definitions/UserId" },
336− "uniqueItems": true
337−}
338−|]
339−
340−-- ========================================================================
341−-- Player (record newtype)
342−-- ========================================================================
343−
344−newtype Player = Player
345− { position :: Point
346− } deriving (Generic)
347−instance ToSchema Player
348−
349−playerSchemaJSON :: Value
350−playerSchemaJSON = [aesonQQ|
351−{
352− "type": "object",
353− "properties":
354− {
355− "position":
356− {
357− "$ref": "#/definitions/Point"
358− }
359− },
360− "required": ["position"]
361−}
362−|]
363−
364−-- ========================================================================
365−-- MyRoseTree (custom datatypeNameModifier)
366−-- ========================================================================
367−
368−data MyRoseTree = MyRoseTree
369− { root :: String
370− , trees :: [MyRoseTree]
371− } deriving (Generic)
372−
373−instance ToSchema MyRoseTree where
374− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
375− { datatypeNameModifier = drop (length "My") }
376−
377−myRoseTreeSchemaJSON :: Value
378−myRoseTreeSchemaJSON = [aesonQQ|
379−{
380− "type": "object",
381− "properties":
382− {
383− "root": { "type": "string" },
384− "trees":
385− {
386− "type": "array",
387− "items":
388− {
389− "$ref": "#/definitions/RoseTree"
390− }
391− }
392− },
393− "required": ["root", "trees"]
394−}
395−|]
396−
397−-- ========================================================================
398−-- Inlined (newtype for inlining schemas)
399−-- ========================================================================
400−
401−newtype Inlined a = Inlined { getInlined :: a }
402−
403−instance ToSchema a => ToSchema (Inlined a) where
404− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
405− where
406− unname (NamedSchema _ s) = NamedSchema Nothing s
407−
408−newtype Players = Players [Inlined Player]
409− deriving (Generic)
410−instance ToSchema Players
411−
412−playersSchemaJSON :: Value
413−playersSchemaJSON = [aesonQQ|
414−{
415− "type": "array",
416− "items":
417− {
418− "type": "object",
419− "properties":
420− {
421− "position":
422− {
423− "$ref": "#/definitions/Point"
424− }
425− },
426− "required": ["position"]
427− }
428−}
429−|]
430−
431−-- ========================================================================
432−-- Status (sum type with unary constructors)
433−-- ========================================================================
434−
435−data Status
436− = StatusOk String
437− | StatusError String
438− deriving (Generic)
439−
440−instance ToSchema Status where
441− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
442− { constructorTagModifier = map toLower . drop (length "Status") }
443−
444−statusSchemaJSON :: Value
445−statusSchemaJSON = [aesonQQ|
446−{
447− "type": "object",
448− "properties":
449− {
450− "ok": { "type": "string" },
451− "error": { "type": "string" }
452− },
453− "maxProperties": 1,
454− "minProperties": 1
455−}
456−|]
457−
458−-- ========================================================================
459−-- Unit type
460−-- ========================================================================
461−
462−data Unit = Unit deriving (Generic)
463−instance ToSchema Unit
464−
465−unitSchemaJSON :: Value
466−unitSchemaJSON = [aesonQQ|
467−{
468− "type": "string",
469− "enum": ["Unit"]
470−}
471−|]
472−
473−
474−-- ========================================================================
475−-- Character (sum type with ref and record in alternative)
476−-- ========================================================================
477−
478−data Character
479− = PC Player
480− | NPC { npcName :: String, npcPosition :: Point }
481− deriving (Generic)
482−instance ToSchema Character
483−
484−characterSchemaJSON :: Value
485−characterSchemaJSON = [aesonQQ|
486−{
487− "type": "object",
488− "properties":
489− {
490− "PC": { "$ref": "#/definitions/Player" },
491− "NPC":
492− {
493− "type": "object",
494− "properties":
495− {
496− "npcName": { "type": "string" },
497− "npcPosition": { "$ref": "#/definitions/Point" }
498− },
499− "required": ["npcName", "npcPosition"]
500− }
501− },
502− "maxProperties": 1,
503− "minProperties": 1
504−}
505−|]
506−
507−characterInlinedSchemaJSON :: Value
508−characterInlinedSchemaJSON = [aesonQQ|
509−{
510− "type": "object",
511− "properties":
512− {
513− "PC":
514− {
515− "type": "object",
516− "properties":
517− {
518− "position":
519− {
520− "type": "object",
521− "properties":
522− {
523− "x": { "type": "number", "format": "double" },
524− "y": { "type": "number", "format": "double" }
525− },
526− "required": ["x", "y"]
527− }
528− },
529− "required": ["position"]
530− },
531− "NPC":
532− {
533− "type": "object",
534− "properties":
535− {
536− "npcName": { "type": "string" },
537− "npcPosition":
538− {
539− "type": "object",
540− "properties":
541− {
542− "x": { "type": "number", "format": "double" },
543− "y": { "type": "number", "format": "double" }
544− },
545− "required": ["x", "y"]
546− }
547− },
548− "required": ["npcName", "npcPosition"]
549− }
550− },
551− "maxProperties": 1,
552− "minProperties": 1
553−}
554−|]
555−
556−characterInlinedPlayerSchemaJSON :: Value
557−characterInlinedPlayerSchemaJSON = [aesonQQ|
558−{
559− "type": "object",
560− "properties":
561− {
562− "PC":
563− {
564− "type": "object",
565− "properties":
566− {
567− "position":
568− {
569− "$ref": "#/definitions/Point"
570− }
571− },
572− "required": ["position"]
573− },
574− "NPC":
575− {
576− "type": "object",
577− "properties":
578− {
579− "npcName": { "type": "string" },
580− "npcPosition": { "$ref": "#/definitions/Point" }
581− },
582− "required": ["npcName", "npcPosition"]
583− }
584− },
585− "maxProperties": 1,
586− "minProperties": 1
587−}
588−|]
589−
590−-- ========================================================================
591−-- Light (sum type with unwrapUnaryRecords)
592−-- ========================================================================
593−
594−data Light
595− = NoLight
596− | LightFreq Double
597− | LightColor Color
598− | LightWaveLength { waveLength :: Double }
599− deriving (Generic)
600−
601−instance ToSchema Light where
602− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
603− { unwrapUnaryRecords = True }
604−
605−lightSchemaJSON :: Value
606−lightSchemaJSON = [aesonQQ|
607−{
608− "type": "object",
609− "properties":
610− {
611− "NoLight": { "type": "array", "items": [] },
612− "LightFreq": { "type": "number", "format": "double" },
613− "LightColor": { "$ref": "#/definitions/Color" },
614− "LightWaveLength": { "type": "number", "format": "double" }
615− },
616− "maxProperties": 1,
617− "minProperties": 1
618−}
619−|]
620−
621−lightInlinedSchemaJSON :: Value
622−lightInlinedSchemaJSON = [aesonQQ|
623−{
624− "type": "object",
625− "properties":
626− {
627− "NoLight": { "type": "array", "items": [] },
628− "LightFreq": { "type": "number", "format": "double" },
629− "LightColor":
630− {
631− "type": "string",
632− "enum": ["Red", "Green", "Blue"]
633− },
634− "LightWaveLength": { "type": "number", "format": "double" }
635− },
636− "maxProperties": 1,
637− "minProperties": 1
638−}
639−|]
640−
641−-- ========================================================================
642−-- ResourceId (series of newtypes)
643−-- ========================================================================
644−
645−newtype Id = Id String deriving (Generic)
646−instance ToSchema Id
647−
648−newtype ResourceId = ResourceId Id deriving (Generic)
649−instance ToSchema ResourceId
test/Data/SwaggerSpec.hs+86−31
@@ -10,9 +10,9 @@ import Prelude.Compat
1010import Control.Lens
1111
1212import Data.Aeson
13−import Data.Aeson.QQ
13+import Data.Aeson.QQ.Simple
1414import Data.HashMap.Strict (HashMap)
15−import qualified Data.Set as Set
15+import qualified Data.HashSet.InsOrd as InsOrdHS
1616import Data.Text (Text)
1717
1818import Data.Swagger
@@ -37,11 +37,13 @@ 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
4041 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
4142 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
4243 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
4344 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
4445 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
4547 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
4648 describe "Swagger Object" $ do
4749 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
@@ -126,7 +128,7 @@ licenseExampleJSON = [aesonQQ|
126128
127129operationExample :: Operation
128130operationExample = mempty
129− & tags .~ Set.fromList ["pet"]
131+ & tags .~ InsOrdHS.fromList ["pet"]
130132 & summary ?~ "Updates a pet in the store with form data"
131133 & description ?~ ""
132134 & operationId ?~ "updatePetWithForm"
@@ -157,7 +159,7 @@ operationExample = mempty
157159 stringSchema :: ParamLocation -> ParamOtherSchema
158160 stringSchema loc = mempty
159161 & in_ .~ loc
160− & type_ .~ SwaggerString
162+ & type_ ?~ SwaggerString
161163
162164operationExampleJSON :: Value
163165operationExampleJSON = [aesonQQ|
@@ -223,7 +225,7 @@ operationExampleJSON = [aesonQQ|
223225
224226schemaPrimitiveExample :: Schema
225227schemaPrimitiveExample = mempty
226− & type_ .~ SwaggerString
228+ & type_ ?~ SwaggerString
227229 & format ?~ "email"
228230
229231schemaPrimitiveExampleJSON :: Value
@@ -236,14 +238,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
236238
237239schemaSimpleModelExample :: Schema
238240schemaSimpleModelExample = mempty
239− & type_ .~ SwaggerObject
241+ & type_ ?~ SwaggerObject
240242 & required .~ [ "name" ]
241243 & properties .~
242− [ ("name", Inline (mempty & type_ .~ SwaggerString))
244+ [ ("name", Inline (mempty & type_ ?~ SwaggerString))
243245 , ("address", Ref (Reference "Address"))
244246 , ("age", Inline $ mempty
245247 & minimum_ ?~ 0
246− & type_ .~ SwaggerInteger
248+ & type_ ?~ SwaggerInteger
247249 & format ?~ "int32" ) ]
248250
249251schemaSimpleModelExampleJSON :: Value
@@ -271,8 +273,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
271273
272274schemaModelDictExample :: Schema
273275schemaModelDictExample = mempty
274− & type_ .~ SwaggerObject
275− & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)
276+ & type_ ?~ SwaggerObject
277+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
276278
277279schemaModelDictExampleJSON :: Value
278280schemaModelDictExampleJSON = [aesonQQ|
@@ -284,15 +286,28 @@ schemaModelDictExampleJSON = [aesonQQ|
284286}
285287|]
286288
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+
287302schemaWithExampleExample :: Schema
288303schemaWithExampleExample = mempty
289− & type_ .~ SwaggerObject
304+ & type_ ?~ SwaggerObject
290305 & properties .~
291306 [ ("id", Inline $ mempty
292− & type_ .~ SwaggerInteger
307+ & type_ ?~ SwaggerInteger
293308 & format ?~ "int64" )
294309 , ("name", Inline $ mempty
295− & type_ .~ SwaggerString) ]
310+ & type_ ?~ SwaggerString) ]
296311 & required .~ [ "name" ]
297312 & example ?~ [aesonQQ|
298313 {
@@ -331,19 +346,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
331346definitionsExample :: HashMap Text Schema
332347definitionsExample =
333348 [ ("Category", mempty
334− & type_ .~ SwaggerObject
349+ & type_ ?~ SwaggerObject
335350 & properties .~
336351 [ ("id", Inline $ mempty
337− & type_ .~ SwaggerInteger
352+ & type_ ?~ SwaggerInteger
338353 & format ?~ "int64")
339− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
354+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
340355 , ("Tag", mempty
341− & type_ .~ SwaggerObject
356+ & type_ ?~ SwaggerObject
342357 & properties .~
343358 [ ("id", Inline $ mempty
344− & type_ .~ SwaggerInteger
359+ & type_ ?~ SwaggerInteger
345360 & format ?~ "int64")
346− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
361+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
347362
348363definitionsExampleJSON :: Value
349364definitionsExampleJSON = [aesonQQ|
@@ -387,7 +402,7 @@ paramsDefinitionExample =
387402 & required ?~ True
388403 & schema .~ ParamOther (mempty
389404 & in_ .~ ParamQuery
390− & type_ .~ SwaggerInteger
405+ & type_ ?~ SwaggerInteger
391406 & format ?~ "int32" ))
392407 , ("limitParam", mempty
393408 & name .~ "limit"
@@ -395,7 +410,7 @@ paramsDefinitionExample =
395410 & required ?~ True
396411 & schema .~ ParamOther (mempty
397412 & in_ .~ ParamQuery
398− & type_ .~ SwaggerInteger
413+ & type_ ?~ SwaggerInteger
399414 & format ?~ "int32" )) ]
400415
401416paramsDefinitionExampleJSON :: Value
@@ -445,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
445460-- Responses Definition object
446461-- =======================================================================
447462
448−securityDefinitionsExample :: HashMap Text SecurityScheme
449−securityDefinitionsExample =
463+securityDefinitionsExample :: SecurityDefinitions
464+securityDefinitionsExample = SecurityDefinitions
450465 [ ("api_key", SecurityScheme
451466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
452467 , _securitySchemeDescription = Nothing })
@@ -478,6 +493,46 @@ securityDefinitionsExampleJSON = [aesonQQ|
478493}
479494|]
480495
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+
481536-- =======================================================================
482537-- Swagger object
483538-- =======================================================================
@@ -496,7 +551,7 @@ swaggerExample = mempty
496551 & at 200 ?~ Inline (mempty
497552 & description .~ "OK"
498553 & schema ?~ Inline (mempty
499− & type_ .~ SwaggerObject
554+ & type_ ?~ SwaggerObject
500555 & example ?~ [aesonQQ|
501556 {
502557 "created": 100,
@@ -505,9 +560,9 @@ swaggerExample = mempty
505560 & description ?~ "This is some real Todo right here"
506561 & properties .~
507562 [ ("created", Inline $ mempty
508− & type_ .~ SwaggerInteger
563+ & type_ ?~ SwaggerInteger
509564 & format ?~ "int32")
510− , ("description", Inline (mempty & type_ .~ SwaggerString))]))
565+ , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
511566 & produces ?~ MimeList [ "application/json" ]
512567 & parameters .~
513568 [ Inline $ mempty
@@ -516,8 +571,8 @@ swaggerExample = mempty
516571 & description ?~ "TodoId param"
517572 & schema .~ ParamOther (mempty
518573 & in_ .~ ParamPath
519− & type_ .~ SwaggerString ) ]
520− & tags .~ Set.fromList [ "todo" ] ))
574+ & type_ ?~ SwaggerString ) ]
575+ & tags .~ InsOrdHS.fromList [ "todo" ] ))
521576
522577swaggerExampleJSON :: Value
523578swaggerExampleJSON = [aesonQQ|
@@ -1618,14 +1673,14 @@ petstoreExampleJSON = [aesonQQ|
16181673
16191674compositionSchemaExample :: Schema
16201675compositionSchemaExample = mempty
1621− & type_ .~ SwaggerObject
1676+ & type_ ?~ SwaggerObject
16221677 & Data.Swagger.allOf ?~ [
16231678 Ref (Reference "Other")
16241679 , Inline (mempty
1625− & type_ .~ SwaggerObject
1680+ & type_ ?~ SwaggerObject
16261681 & properties .~
16271682 [ ("greet", Inline $ mempty
1628− & type_ .~ SwaggerString) ])
1683+ & type_ ?~ SwaggerString) ])
16291684 ]
16301685
16311686compositionSchemaExampleJSON :: Value