git.iko.soy/typeable/swagger2
on ddbca29 help sign in
5470313
swap
0 ahead, 129 behind
32 files changed+1125−2700
since splitsnapshots
unifiedsplit
.ghci−1 .travis.yml+81−140 CHANGELOG.md+3−80 aeson-0.11.cabal.config+1 cabal.project−2 examples/hackage.hs+1−1 hackage-docs.sh−78 src/Data/Swagger.hs+4−10 src/Data/Swagger/Declare.hs+5−4 src/Data/Swagger/Internal.hs+29−146 src/Data/Swagger/Internal/AesonUtils.hs+3−16 src/Data/Swagger/Internal/ParamSchema.hs+26−44 src/Data/Swagger/Internal/Schema.hs+75−96 src/Data/Swagger/Internal/Schema/Validation.hs+50−212 src/Data/Swagger/Internal/Utils.hs+1 src/Data/Swagger/Lens.hs+4−10 src/Data/Swagger/Operation.hs+5−5 src/Data/Swagger/Optics.hs−597 src/Data/Swagger/Schema.hs−1 src/Data/Swagger/Schema/Generator.hs−114 src/Data/Swagger/Schema/Validation.hs−2 src/Data/Swagger/SchemaOptions.hs−29 stack-ghc-8.0.yaml+5 stack-lts-2.yaml+22 stack.yaml+2−6 swagger2.cabal+50−84 test/Data/Swagger/CommonTestTypes.hs−679 test/Data/Swagger/ParamSchemaSpec.hs+84−8 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs+55−71 test/Data/Swagger/SchemaSpec.hs+588−10 test/Data/SwaggerSpec.hs+31−86
.ghci−1
@@ -1,2 +1 @@
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+81−140
@@ -1,162 +1,103 @@
11# This Travis job script has been generated by a script via
22#
3−# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal'
3+# make_travis_yml_2.hs '--branch' 'master' 'swagger2.cabal'
44#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.5.20191020
5+# For more information, see https://github.com/hvr/multi-ghc-travis
86#
97language: c
10−dist: xenial
8+sudo: false
9+
1110git:
12− # whether to recursively clone submodules
13− submodules: false
11+ submodules: false # whether to recursively clone submodules
12+
1413branches:
1514 only:
1615 - master
16+
1717cache:
1818 directories:
1919 - $HOME/.cabal/packages
2020 - $HOME/.cabal/store
21+
2122before_cache:
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
2324 # remove files that are regenerated by 'cabal update'
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
27− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
28− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
29− - rm -rfv $CABALHOME/packages/head.hackage
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+
3031matrix:
3132 include:
32− - compiler: ghc-8.8.1
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
34− - compiler: ghc-8.6.5
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
36− - compiler: ghc-8.4.4
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
38− - compiler: ghc-8.2.2
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
40− - compiler: ghc-8.0.2
41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
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+
4249before_install:
43− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
44− - WITHCOMPILER="-w $HC"
45− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
46− - HCPKG="$HC-pkg"
47− - unset CC
48− - CABAL=/opt/ghc/bin/cabal
49− - CABALHOME=$HOME/.cabal
50− - export PATH="$CABALHOME/bin:$PATH"
51− - TOP=$(pwd)
52− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
53− - echo $HCNUMVER
54− - CABAL="$CABAL -vnormal+nowrap+markoutput"
55− - set -o pipefail
56− - |
57− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
58− echo 'BEGIN { state = "output"; }' >> .colorful.awk
59− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
60− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
61− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
62− echo ' if (state == "cabal") {' >> .colorful.awk
63− echo ' print blue($0)' >> .colorful.awk
64− echo ' } else {' >> .colorful.awk
65− echo ' print $0' >> .colorful.awk
66− echo ' }' >> .colorful.awk
67− echo '}' >> .colorful.awk
68− - cat .colorful.awk
69− - |
70− color_cabal_output () {
71− awk -f $TOP/.colorful.awk
72− }
73− - echo text | color_cabal_output
50+ - HC=${CC}
51+ - unset CC
52+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
53+ - PKGNAME='swagger2'
54+
7455install:
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
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.
12672script:
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
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
160102
161−# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
162103# EOF
CHANGELOG.md+3−80
@@ -1,86 +1,9 @@
1−2.5
2−---
3−
4−Highlights:
5−- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));
6−- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));
7−- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));
8−
9−Fixes and minor changes:
10−- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));
11−- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));
12−- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));
13−
14−2.4
15−---
16−
17−- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5
18−- Tags aren't sorted
19− (see [#165](https://github.com/GetShopTV/swagger2/issues/165))
20−- Schema type is optional
21− (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))
22−- Take concrete 'Proxy' as argument
23− (see [#180](https://github.com/GetShopTV/swagger2/pull/180))
24−- GHC-8.8 preparations
25−
26−2.3.1.1
27−-------
28−
29−- Allow `network-3.0`
30−
31−2.3.1
32−-----
33−
34−- Add a quickcheck generator for aeson Values that match a swagger schema
35− (see [#162](https://github.com/GetShopTV/swagger2/pull/162))
36−- Add `ToParamSchema` instance for `SetCookie`
37− (see [#173](https://github.com/GetShopTV/swagger2/pull/173))
38−- Make nullary schemas valid
39− (see [#168](https://github.com/GetShopTV/swagger2/pull/168))
40−
41−2.3.0.1
42−-------
43−
44−- Support GHC-8.6
45−
46−2.3
47−---
48−
49−Major changes:
50−
51−- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));
52−- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));
53−
54−Dependencies and CI:
55−
56−- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));
57−- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));
58−- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));
59−- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));
60−
61−2.2.2
62−-----
63−
64−* Add `ToSchema Version` instance
65−* Use base-compat-batteries (0.10)
66−* PVP bounds
67−
68−2.2.1
69−-----
70−
71−* Add `Semigroup` instances
72−* GHC-8.4 compatibility
73−* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))
74−* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))
75−* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))
76−* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))
77−
7812.2
792---
803
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)):
4+* Treat unknown properties as validation errors in `validateToJSON`;
5+* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes;
6+* Add more `Schema` helpers:
847 * `genericNameSchema` — to give a custom schema `Generic`-based name;
858 * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;
869 * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;
aeson-0.11.cabal.confignew file+1
@@ -0,0 +1 @@
1+constraints: aeson ==0.11.*
cabal.projectdeleted−2
@@ -1,2 +0,0 @@
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.shdeleted−78
@@ -1,78 +0,0 @@
1−#!/bin/bash
2−set -e
3−
4−# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh
5−
6−if [ "$#" -ne 1 ]; then
7− echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"
8− exit 1
9−fi
10−
11−user=$1
12−
13−cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)
14−if [ ! -f "$cabal_file" ]; then
15− echo "Run this script in the top-level package directory"
16− exit 1
17−fi
18−
19−pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")
20−ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")
21−
22−if [ -z "$pkg" ]; then
23− echo "Unable to determine package name"
24− exit 1
25−fi
26−
27−if [ -z "$ver" ]; then
28− echo "Unable to determine package version"
29− exit 1
30−fi
31−
32−echo "Detected package: $pkg-$ver"
33−
34−dir=$(mktemp -d build-docs.XXXXXX)
35−trap 'rm -r "$dir"' EXIT
36−
37−export PATH=$(stack path --bin-path)
38−
39−ghc --version
40−cabal --version
41−stack --version
42−
43−if haddock --hyperlinked-source >/dev/null
44−then
45− echo "Using fancy hyperlinked source"
46− HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"
47−else
48− echo "Using boring hyperlinked source"
49− HYPERLINK_FLAG="--hyperlink-source"
50−fi
51−
52−# Cabal dist in temporary location
53−builddir=$dir/dist
54−
55−# Build dependencies haddocks with stack, so we get links
56−stack haddock --only-dependencies
57−
58−# Configure using stack databases
59−snapshotpkgdb=$(stack path --snapshot-pkg-db)
60−localpkgdb=$(stack path --local-pkg-db)
61−cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb
62−
63−# Build Hadckage compatible docs
64−cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'
65−
66−# Copy into right directory
67−cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs
68−
69−# Tar and gzip
70−tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs
71−
72−# Upload
73−curl -X PUT \
74− -H 'Content-Type: application/x-tar' \
75− -H 'Content-Encoding: gzip' \
76− -u "$user" \
77− --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \
78− "https://hackage.haskell.org/package/$pkg-$ver/docs"
src/Data/Swagger.hs+4−10
@@ -31,7 +31,6 @@ module Data.Swagger (
3131
3232 -- * Re-exports
3333 module Data.Swagger.Lens,
34− module Data.Swagger.Optics,
3534 module Data.Swagger.Operation,
3635 module Data.Swagger.ParamSchema,
3736 module Data.Swagger.Schema,
@@ -78,7 +77,6 @@ module Data.Swagger (
7877 SwaggerItems(..),
7978 Xml(..),
8079 Pattern,
81− AdditionalProperties(..),
8280
8381 -- ** Responses
8482 Responses(..),
@@ -89,7 +87,6 @@ module Data.Swagger (
8987 SecurityScheme(..),
9088 SecuritySchemeType(..),
9189 SecurityRequirement(..),
92− SecurityDefinitions(..),
9390
9491 -- *** API key
9592 ApiKeyParams(..),
@@ -114,7 +111,6 @@ module Data.Swagger (
114111) where
115112
116113import Data.Swagger.Lens
117−import Data.Swagger.Optics ()
118114import Data.Swagger.Operation
119115import Data.Swagger.ParamSchema
120116import Data.Swagger.Schema
@@ -178,15 +174,13 @@ import Data.Swagger.Internal
178174
179175-- $lens
180176--
181−-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182−--
183177-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
184178-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
185179-- make it fairly simple to construct/modify any part of the specification:
186180--
187181-- >>> :{
188182-- encode $ (mempty :: Swagger)
189−-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
183+-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
190184-- & paths .~
191185-- [ ("/user", mempty & get ?~ (mempty
192186-- & produces ?~ MimeList ["application/json"]
@@ -209,7 +203,7 @@ import Data.Swagger.Internal
209203-- "{\"description\":\"No content\"}"
210204-- >>> :{
211205-- encode $ (mempty :: Schema)
212−-- & type_ ?~ SwaggerBoolean
206+-- & type_ .~ SwaggerBoolean
213207-- & description ?~ "To be or not to be"
214208-- :}
215209-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
@@ -218,7 +212,7 @@ import Data.Swagger.Internal
218212-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
219213-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
220214--
221−-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
215+-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
222216-- "{\"type\":\"number\"}"
223217--
224218-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
@@ -280,7 +274,7 @@ import Data.Swagger.Internal
280274-- >>> encode $ toSchema (Proxy :: Proxy Person)
281275-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
282276--
283−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
277+-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
284278-- schema for basic enums like
285279--
286280-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
src/Data/Swagger/Declare.hs+5−4
@@ -29,6 +29,7 @@ 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
3233
3334-- | A declare monad transformer parametrized by:
3435--
@@ -49,15 +50,15 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
4950 pure x = DeclareT (\_ -> pure (mempty, x))
5051 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
5152 ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
53− return (mappend d' d'', f x)
53+ ~(d'', x) <- dx (d <> d')
54+ return (d' <> d'', f x)
5455
5556instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
5657 return x = DeclareT (\_ -> pure (mempty, x))
5758 DeclareT dx >>= f = DeclareT $ \d -> do
5859 ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
60− return (mappend d' d'', y)
60+ ~(d'', y) <- runDeclareT (f x) (d <> d')
61+ return (d' <> d'', y)
6162
6263instance Monoid d => MonadTrans (DeclareT d) where
6364 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
src/Data/Swagger/Internal.hs+29−146
@@ -29,19 +29,17 @@ 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)
3332import qualified Data.HashMap.Strict as HashMap
34−import Data.HashSet.InsOrd (InsOrdHashSet)
3533import Data.Map (Map)
3634import qualified Data.Map as Map
37−import Data.Monoid (Monoid (..))
38−import Data.Semigroup.Compat (Semigroup (..))
35+import Data.Monoid
3936import Data.Scientific (Scientific)
37+import Data.Set (Set)
4038import Data.String (IsString(..))
4139import Data.Text (Text)
4240import qualified Data.Text as Text
4341import GHC.Generics (Generic)
44−import Network.Socket (HostName, PortNumber)
42+import Network (HostName, PortNumber)
4543import Network.HTTP.Media (MediaType)
4644import Text.Read (readMaybe)
4745
@@ -66,10 +64,6 @@ import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)
6664#define DEFINE_TOENCODING
6765#endif
6866
69−-- $setup
70−-- >>> :seti -XDataKinds
71−-- >>> import Data.Aeson
72−
7367-- | A list of definitions that can be used in references.
7468type Definitions = InsOrdHashMap Text
7569
@@ -117,7 +111,7 @@ data Swagger = Swagger
117111 , _swaggerResponses :: Definitions Response
118112
119113 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: SecurityDefinitions
114+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme
121115
122116 -- | A declaration of which security schemes are applied for the API as a whole.
123117 -- The list of values describes alternative security schemes that can be used
@@ -130,7 +124,7 @@ data Swagger = Swagger
130124 -- Not all tags that are used by the Operation Object must be declared.
131125 -- The tags that are not declared may be organized randomly or based on the tools' logic.
132126 -- Each tag name in the list MUST be unique.
133− , _swaggerTags :: InsOrdHashSet Tag
127+ , _swaggerTags :: Set Tag
134128
135129 -- | Additional external documentation.
136130 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -252,7 +246,7 @@ data PathItem = PathItem
252246data Operation = Operation
253247 { -- | A list of tags for API documentation control.
254248 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
255− _operationTags :: InsOrdHashSet TagName
249+ _operationTags :: Set TagName
256250
257251 -- | A short summary of what the operation does.
258252 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -309,7 +303,7 @@ data Operation = Operation
309303 } deriving (Eq, Show, Generic, Data, Typeable)
310304
311305newtype MimeList = MimeList { getMimeList :: [MediaType] }
312− deriving (Eq, Show, Semigroup, Monoid, Typeable)
306+ deriving (Eq, Show, Monoid, Typeable)
313307
314308mimeListConstr :: Constr
315309mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -562,7 +556,7 @@ data Schema = Schema
562556
563557 , _schemaAllOf :: Maybe [Referenced Schema]
564558 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565− , _schemaAdditionalProperties :: Maybe AdditionalProperties
559+ , _schemaAdditionalProperties :: Maybe (Referenced Schema)
566560
567561 , _schemaDiscriminator :: Maybe Text
568562 , _schemaReadOnly :: Maybe Bool
@@ -594,7 +588,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
594588 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
595589 _paramSchemaDefault :: Maybe Value
596590
597− , _paramSchemaType :: Maybe (SwaggerType t)
591+ , _paramSchemaType :: SwaggerType t
598592 , _paramSchemaFormat :: Maybe Format
599593 , _paramSchemaItems :: Maybe (SwaggerItems t)
600594 , _paramSchemaMaximum :: Maybe Scientific
@@ -611,7 +605,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
611605 , _paramSchemaMultipleOf :: Maybe Scientific
612606 } deriving (Eq, Show, Generic, Typeable)
613607
614−deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)
608+deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)
615609
616610data Xml = Xml
617611 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -755,28 +749,12 @@ data SecurityScheme = SecurityScheme
755749 , _securitySchemeDescription :: Maybe Text
756750 } deriving (Eq, Show, Generic, Data, Typeable)
757751
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−
774752-- | Lists the required security schemes to execute this operation.
775753-- The object can have multiple security schemes declared in it which are all required
776754-- (that is, there is a logical AND between the schemes).
777755newtype SecurityRequirement = SecurityRequirement
778756 { getSecurityRequirement :: InsOrdHashMap Text [Text]
779− } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)
757+ } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)
780758
781759-- | Tag name.
782760type TagName = Text
@@ -795,8 +773,6 @@ data Tag = Tag
795773 , _tagExternalDocs :: Maybe ExternalDocs
796774 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797775
798−instance Hashable Tag
799−
800776instance IsString Tag where
801777 fromString s = Tag (fromString s) Nothing Nothing
802778
@@ -810,8 +786,6 @@ data ExternalDocs = ExternalDocs
810786 , _externalDocsUrl :: URL
811787 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812788
813−instance Hashable ExternalDocs
814−
815789-- | A simple object to allow referencing other definitions in the specification.
816790-- It can be used to reference parameters and responses that are defined at the top level for reuse.
817791newtype Reference = Reference { getReference :: Text }
@@ -825,111 +799,67 @@ data Referenced a
825799instance IsString a => IsString (Referenced a) where
826800 fromString = Inline . fromString
827801
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)
802+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)
834803
835804-- =======================================================================
836805-- Monoid instances
837806-- =======================================================================
838807
839−instance Semigroup Swagger where
840− (<>) = genericMappend
841808instance Monoid Swagger where
842809 mempty = genericMempty
843− mappend = (<>)
810+ mappend = genericMappend
844811
845−instance Semigroup Info where
846− (<>) = genericMappend
847812instance Monoid Info where
848813 mempty = genericMempty
849− mappend = (<>)
814+ mappend = genericMappend
850815
851−instance Semigroup Contact where
852− (<>) = genericMappend
853816instance Monoid Contact where
854817 mempty = genericMempty
855− mappend = (<>)
818+ mappend = genericMappend
856819
857−instance Semigroup PathItem where
858− (<>) = genericMappend
859820instance Monoid PathItem where
860821 mempty = genericMempty
861− mappend = (<>)
822+ mappend = genericMappend
862823
863−instance Semigroup Schema where
864− (<>) = genericMappend
865824instance Monoid Schema where
866825 mempty = genericMempty
867− mappend = (<>)
826+ mappend = genericMappend
868827
869−instance Semigroup (ParamSchema t) where
870− (<>) = genericMappend
871828instance Monoid (ParamSchema t) where
872829 mempty = genericMempty
873− mappend = (<>)
830+ mappend = genericMappend
874831
875−instance Semigroup Param where
876− (<>) = genericMappend
877832instance Monoid Param where
878833 mempty = genericMempty
879− mappend = (<>)
834+ mappend = genericMappend
880835
881−instance Semigroup ParamOtherSchema where
882− (<>) = genericMappend
883836instance Monoid ParamOtherSchema where
884837 mempty = genericMempty
885− mappend = (<>)
838+ mappend = genericMappend
886839
887−instance Semigroup Header where
888− (<>) = genericMappend
889840instance Monoid Header where
890841 mempty = genericMempty
891− mappend = (<>)
842+ mappend = genericMappend
892843
893−instance Semigroup Responses where
894− (<>) = genericMappend
895844instance Monoid Responses where
896845 mempty = genericMempty
897− mappend = (<>)
846+ mappend = genericMappend
898847
899−instance Semigroup Response where
900− (<>) = genericMappend
901848instance Monoid Response where
902849 mempty = genericMempty
903− mappend = (<>)
850+ mappend = genericMappend
904851
905−instance Semigroup ExternalDocs where
906− (<>) = genericMappend
907852instance Monoid ExternalDocs where
908853 mempty = genericMempty
909− mappend = (<>)
854+ mappend = genericMappend
910855
911−instance Semigroup Operation where
912− (<>) = genericMappend
913856instance Monoid Operation where
914857 mempty = genericMempty
915− mappend = (<>)
858+ mappend = genericMappend
916859
917−instance Semigroup Example where
918− (<>) = genericMappend
919860instance Monoid Example where
920861 mempty = genericMempty
921− mappend = (<>)
922−
923−instance Semigroup SecurityScheme where
924− (<>) = mergeSecurityScheme
925−
926−instance Semigroup SecurityDefinitions where
927− (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
928− SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
929−
930−instance Monoid SecurityDefinitions where
931− mempty = SecurityDefinitions $ InsOrdHashMap.empty
932− mappend = (<>)
862+ mappend = genericMappend
933863
934864-- =======================================================================
935865-- SwaggerMonoid helper instances
@@ -945,8 +875,6 @@ instance SwaggerMonoid Responses
945875instance SwaggerMonoid Response
946876instance SwaggerMonoid ExternalDocs
947877instance SwaggerMonoid Operation
948−instance SwaggerMonoid SecurityDefinitions
949−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
950878
951879instance SwaggerMonoid MimeList
952880deriving instance SwaggerMonoid URL
@@ -965,7 +893,7 @@ instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
965893
966894instance Monoid a => SwaggerMonoid (Referenced a) where
967895 swaggerMempty = Inline mempty
968− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
896+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
969897 swaggerMappend _ y = y
970898
971899instance SwaggerMonoid ParamAnySchema where
@@ -1088,22 +1016,11 @@ instance ToJSON Header where
10881016 toJSON = sopSwaggerGenericToJSON
10891017 DEFINE_TOENCODING
10901018
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−--
10971019instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
10981020 toJSON (SwaggerItemsPrimitive fmt schema) = object
10991021 [ "collectionFormat" .= fmt
11001022 , "items" .= schema ]
11011023 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102− toJSON (SwaggerItemsArray []) = object
1103− [ "items" .= object []
1104− , "maxItems" .= (0 :: Int)
1105− , "example" .= Array mempty
1106− ]
11071024 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
11081025
11091026instance ToJSON Host where
@@ -1146,9 +1063,6 @@ instance ToJSON PathItem where
11461063instance ToJSON Example where
11471064 toJSON = toJSON . Map.mapKeys show . getExample
11481065
1149−instance ToJSON SecurityDefinitions where
1150− toJSON (SecurityDefinitions sd) = toJSON sd
1151−
11521066instance ToJSON Reference where
11531067 toJSON (Reference ref) = object [ "$ref" .= ref ]
11541068
@@ -1182,10 +1096,6 @@ instance ToJSON (ParamSchema k) where
11821096 toJSON = sopSwaggerGenericToJSONWithOpts $
11831097 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
11841098
1185−instance ToJSON AdditionalProperties where
1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187− toJSON (AdditionalPropertiesSchema s) = toJSON s
1188−
11891099-- =======================================================================
11901100-- Manual FromJSON instances
11911101-- =======================================================================
@@ -1223,13 +1133,7 @@ instance FromJSON SecurityScheme where
12231133 parseJSON = sopSwaggerGenericParseJSON
12241134
12251135instance FromJSON Schema where
1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1227− where nullaryCleanup :: Schema -> Schema
1228− nullaryCleanup s@Schema{_schemaParamSchema=ps} =
1229− if _paramSchemaItems ps == Just (SwaggerItemsArray [])
1230− then s { _schemaExample = Nothing
1231− , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }
1232− else s
1136+ parseJSON = sopSwaggerGenericParseJSON
12331137
12341138instance FromJSON Header where
12351139 parseJSON = sopSwaggerGenericParseJSON
@@ -1244,21 +1148,8 @@ instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
12441148 <$> o .:? "collectionFormat"
12451149 <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
12461150
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−--
12581151instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1259− parseJSON js@(Object obj)
1260− | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.
1261− | otherwise = SwaggerItemsObject <$> parseJSON js
1152+ parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js
12621153 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
12631154 parseJSON _ = empty
12641155
@@ -1310,9 +1201,6 @@ instance FromJSON Operation where
13101201instance FromJSON PathItem where
13111202 parseJSON = sopSwaggerGenericParseJSON
13121203
1313−instance FromJSON SecurityDefinitions where
1314− parseJSON js = SecurityDefinitions <$> parseJSON js
1315−
13161204instance FromJSON Reference where
13171205 parseJSON (Object o) = Reference <$> o .: "$ref"
13181206 parseJSON _ = empty
@@ -1363,10 +1251,6 @@ instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
13631251instance FromJSON (ParamSchema 'SwaggerKindSchema) where
13641252 parseJSON = sopSwaggerGenericParseJSON
13651253
1366−instance FromJSON AdditionalProperties where
1367− parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1369−
13701254-------------------------------------------------------------------------------
13711255-- TH splices
13721256-------------------------------------------------------------------------------
@@ -1424,4 +1308,3 @@ instance AesonDefaultValue (SwaggerType a)
14241308instance AesonDefaultValue MimeList where defaultValue = Just mempty
14251309instance AesonDefaultValue Info
14261310instance AesonDefaultValue ParamLocation
1427−instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty
src/Data/Swagger/Internal/AesonUtils.hs+3−16
@@ -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
4847
4948#if MIN_VERSION_aeson(0,10,0)
5049import 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,7 +86,6 @@ 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
9089instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
9190
9291-------------------------------------------------------------------------------
@@ -146,11 +145,7 @@ sopSwaggerGenericToJSON'
146145 -> DatatypeInfo '[xs]
147146 -> POP Maybe '[xs]
148147 -> [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
152148sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
153−#endif
154149 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
155150sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
156151
@@ -226,11 +221,7 @@ sopSwaggerGenericParseJSON'
226221 -> DatatypeInfo '[xs]
227222 -> POP Maybe '[xs]
228223 -> 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
232224sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
233−#endif
234225 SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
235226sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
236227
@@ -302,11 +293,7 @@ sopSwaggerGenericToEncoding'
302293 -> DatatypeInfo '[xs]
303294 -> POP Maybe '[xs]
304295 -> 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
308296sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
309−#endif
310297 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
311298sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
312299
src/Data/Swagger/Internal/ParamSchema.hs+26−44
@@ -39,11 +39,9 @@ import qualified Data.Vector as V
3939import qualified Data.Vector.Primitive as VP
4040import qualified Data.Vector.Storable as VS
4141import qualified Data.Vector.Unboxed as VU
42−import Data.Version (Version)
43−import Numeric.Natural.Compat (Natural)
42+import Numeric.Natural
4443import Data.Word
4544import Data.UUID.Types (UUID)
46−import Web.Cookie (SetCookie)
4745
4846import Data.Swagger.Internal
4947import Data.Swagger.Lens
@@ -59,20 +57,20 @@ import GHC.TypeLits (TypeError, ErrorMessage(..))
5957-- | Default schema for binary data (any sequence of octets).
6058binaryParamSchema :: ParamSchema t
6159binaryParamSchema = mempty
62− & type_ ?~ SwaggerString
60+ & type_ .~ SwaggerString
6361 & format ?~ "binary"
6462
6563-- | Default schema for binary data (base64 encoded).
6664byteParamSchema :: ParamSchema t
6765byteParamSchema = mempty
68− & type_ ?~ SwaggerString
66+ & type_ .~ SwaggerString
6967 & format ?~ "byte"
7068
7169-- | Default schema for password string.
7270-- @"password"@ format is used to hint UIs the input needs to be obscured.
7371passwordParamSchema :: ParamSchema t
7472passwordParamSchema = mempty
75− & type_ ?~ SwaggerString
73+ & type_ .~ SwaggerString
7674 & format ?~ "password"
7775
7876-- | Convert a type into a plain @'ParamSchema'@.
@@ -88,7 +86,7 @@ passwordParamSchema = mempty
8886--
8987-- instance ToParamSchema Direction where
9088-- toParamSchema _ = mempty
91−-- & type_ ?~ SwaggerString
89+-- & type_ .~ SwaggerString
9290-- & enum_ ?~ [ \"Up\", \"Down\" ]
9391-- @
9492--
@@ -115,22 +113,22 @@ class ToParamSchema a where
115113 --
116114 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
117115 -- "{\"type\":\"integer\"}"
118− toParamSchema :: Proxy a -> ParamSchema t
119− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
116+ toParamSchema :: proxy a -> ParamSchema t
117+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
120118 toParamSchema = genericToParamSchema defaultSchemaOptions
121119
122120instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ ?~ SwaggerString
121+ toParamSchema _ = mempty & type_ .~ SwaggerString
124122
125123instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
124+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean
127125
128126instance ToParamSchema Integer where
129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger
127+ toParamSchema _ = mempty & type_ .~ SwaggerInteger
130128
131129instance ToParamSchema Natural where
132130 toParamSchema _ = mempty
133− & type_ ?~ SwaggerInteger
131+ & type_ .~ SwaggerInteger
134132 & minimum_ ?~ 0
135133 & exclusiveMinimum ?~ False
136134
@@ -154,51 +152,45 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
154152--
155153-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156154-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
155+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
158156toParamSchemaBoundedIntegral _ = mempty
159− & type_ ?~ SwaggerInteger
157+ & type_ .~ SwaggerInteger
160158 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161159 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162160
163161instance ToParamSchema Char where
164162 toParamSchema _ = mempty
165− & type_ ?~ SwaggerString
163+ & type_ .~ SwaggerString
166164 & maxLength ?~ 1
167165 & minLength ?~ 1
168166
169167instance ToParamSchema Scientific where
170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber
168+ toParamSchema _ = mempty & type_ .~ SwaggerNumber
171169
172170instance HasResolution a => ToParamSchema (Fixed a) where
173171 toParamSchema _ = mempty
174− & type_ ?~ SwaggerNumber
172+ & type_ .~ SwaggerNumber
175173 & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
176174
177175instance ToParamSchema Double where
178176 toParamSchema _ = mempty
179− & type_ ?~ SwaggerNumber
177+ & type_ .~ SwaggerNumber
180178 & format ?~ "double"
181179
182180instance ToParamSchema Float where
183181 toParamSchema _ = mempty
184− & type_ ?~ SwaggerNumber
182+ & type_ .~ SwaggerNumber
185183 & format ?~ "float"
186184
187185timeParamSchema :: String -> ParamSchema t
188186timeParamSchema fmt = mempty
189− & type_ ?~ SwaggerString
187+ & type_ .~ SwaggerString
190188 & format ?~ T.pack fmt
191189
192190-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
193191instance ToParamSchema Day where
194192 toParamSchema _ = timeParamSchema "date"
195193
196−-- |
197−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198−-- Just "hh:MM:ss"
199−instance ToParamSchema TimeOfDay where
200− toParamSchema _ = timeParamSchema "hh:MM:ss"
201−
202194-- |
203195-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
204196-- Just "yyyy-mm-ddThh:MM:ss"
@@ -226,16 +218,6 @@ instance ToParamSchema T.Text where
226218instance ToParamSchema TL.Text where
227219 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
228220
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−
239221#if __GLASGOW_HASKELL__ < 800
240222#else
241223type family ToParamSchemaByteStringError bs where
@@ -260,7 +242,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t
260242
261243instance ToParamSchema a => ToParamSchema [a] where
262244 toParamSchema _ = mempty
263− & type_ ?~ SwaggerArray
245+ & type_ .~ SwaggerArray
264246 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
265247
266248instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -280,12 +262,12 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
280262-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
281263instance ToParamSchema () where
282264 toParamSchema _ = mempty
283− & type_ ?~ SwaggerString
265+ & type_ .~ SwaggerString
284266 & enum_ ?~ ["_"]
285267
286268instance ToParamSchema UUID where
287269 toParamSchema _ = mempty
288− & type_ ?~ SwaggerString
270+ & type_ .~ SwaggerString
289271 & format ?~ "uuid"
290272
291273-- | A configurable generic @'ParamSchema'@ creator.
@@ -294,11 +276,11 @@ instance ToParamSchema UUID where
294276-- >>> data Color = Red | Blue deriving Generic
295277-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
296278-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
279+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
298280genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
299281
300282class GToParamSchema (f :: * -> *) where
301− gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
283+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
302284
303285instance GToParamSchema f => GToParamSchema (D1 d f) where
304286 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -316,14 +298,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
316298 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
317299
318300class GEnumParamSchema (f :: * -> *) where
319− genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
301+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
320302
321303instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
322304 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
323305
324306instance Constructor c => GEnumParamSchema (C1 c U1) where
325307 genumParamSchema opts _ s = s
326− & type_ ?~ SwaggerString
308+ & type_ .~ SwaggerString
327309 & enum_ %~ addEnumValue tag
328310 where
329311 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
src/Data/Swagger/Internal/Schema.hs+75−96
@@ -32,7 +32,7 @@ import Data.Data.Lens (template)
3232
3333import Control.Monad
3434import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
35+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..))
3636import Data.Char
3737import Data.Data (Data)
3838import Data.Foldable (traverse_)
@@ -44,7 +44,6 @@ 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)
4847import Data.Map (Map)
4948import Data.Proxy
5049import Data.Scientific (Scientific)
@@ -57,8 +56,7 @@ import qualified Data.Vector as V
5756import qualified Data.Vector.Primitive as VP
5857import qualified Data.Vector.Storable as VS
5958import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
59+import Numeric.Natural
6260import Data.Word
6361import GHC.Generics
6462import qualified Data.UUID.Types as UUID
@@ -111,7 +109,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
111109-- declareNamedSchema _ = do
112110-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113111-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ ?~ SwaggerObject
112+-- & type_ .~ SwaggerObject
115113-- & properties .~
116114-- [ (\"x\", doubleSchema)
117115-- , (\"y\", doubleSchema)
@@ -142,17 +140,13 @@ class ToSchema a where
142140 -- together with all used definitions.
143141 -- Note that the schema itself is included in definitions
144142 -- only if it is recursive (and thus needs its definition in scope).
145− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
143+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
146144 default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
147− Proxy a -> Declare (Definitions Schema) NamedSchema
145+ proxy a -> Declare (Definitions Schema) NamedSchema
148146 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149147
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154148-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
149+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
156150declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157151
158152-- | Convert a type into an optionally named schema.
@@ -166,7 +160,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
166160-- Just "Day"
167161-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168162-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
163+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
170164toNamedSchema = undeclare . declareNamedSchema
171165
172166-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -176,7 +170,7 @@ toNamedSchema = undeclare . declareNamedSchema
176170--
177171-- >>> schemaName (Proxy :: Proxy UTCTime)
178172-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
173+schemaName :: ToSchema a => proxy a -> Maybe T.Text
180174schemaName = _namedSchemaName . toNamedSchema
181175
182176-- | Convert a type into a schema.
@@ -186,7 +180,7 @@ schemaName = _namedSchemaName . toNamedSchema
186180--
187181-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188182-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
183+toSchema :: ToSchema a => proxy a -> Schema
190184toSchema = _namedSchemaSchema . toNamedSchema
191185
192186-- | Convert a type into a referenced schema if possible.
@@ -197,7 +191,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
197191--
198192-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199193-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
194+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
201195toSchemaRef = undeclare . declareSchemaRef
202196
203197-- | Convert a type into a referenced schema if possible
@@ -207,7 +201,7 @@ toSchemaRef = undeclare . declareSchemaRef
207201-- Schema definitions are typically declared for every referenced schema.
208202-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209203-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
204+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
211205declareSchemaRef proxy = do
212206 case toNamedSchema proxy of
213207 NamedSchema (Just name) schema -> do
@@ -269,7 +263,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)
269263--
270264-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271265-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
266+toInlinedSchema :: ToSchema a => proxy a -> Schema
273267toInlinedSchema proxy = inlineAllSchemas defs schema
274268 where
275269 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -298,20 +292,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
298292-- | Default schema for binary data (any sequence of octets).
299293binarySchema :: Schema
300294binarySchema = mempty
301− & type_ ?~ SwaggerString
295+ & type_ .~ SwaggerString
302296 & format ?~ "binary"
303297
304298-- | Default schema for binary data (base64 encoded).
305299byteSchema :: Schema
306300byteSchema = mempty
307− & type_ ?~ SwaggerString
301+ & type_ .~ SwaggerString
308302 & format ?~ "byte"
309303
310304-- | Default schema for password string.
311305-- @"password"@ format is used to hint UIs the input needs to be obscured.
312306passwordSchema :: Schema
313307passwordSchema = mempty
314− & type_ ?~ SwaggerString
308+ & type_ .~ SwaggerString
315309 & format ?~ "password"
316310
317311-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -337,12 +331,12 @@ sketchSchema = sketch . toJSON
337331 sketch js@(Bool _) = go js
338332 sketch js = go js & example ?~ js
339333
340− go Null = mempty & type_ ?~ SwaggerNull
341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
342− go (String _) = mempty & type_ ?~ SwaggerString
343− go (Number _) = mempty & type_ ?~ SwaggerNumber
334+ go Null = mempty & type_ .~ SwaggerNull
335+ go (Bool _) = mempty & type_ .~ SwaggerBoolean
336+ go (String _) = mempty & type_ .~ SwaggerString
337+ go (Number _) = mempty & type_ .~ SwaggerNumber
344338 go (Array xs) = mempty
345− & type_ ?~ SwaggerArray
339+ & type_ .~ SwaggerArray
346340 & items ?~ case ischema of
347341 Just s -> SwaggerItemsObject (Inline s)
348342 _ -> SwaggerItemsArray (map Inline ys)
@@ -354,7 +348,7 @@ sketchSchema = sketch . toJSON
354348 (z:_) | allSame -> Just z
355349 _ -> Nothing
356350 go (Object o) = mempty
357− & type_ ?~ SwaggerObject
351+ & type_ .~ SwaggerObject
358352 & required .~ HashMap.keys o
359353 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
360354
@@ -377,24 +371,24 @@ sketchSchema = sketch . toJSON
377371sketchStrictSchema :: ToJSON a => a -> Schema
378372sketchStrictSchema = go . toJSON
379373 where
380− go Null = mempty & type_ ?~ SwaggerNull
374+ go Null = mempty & type_ .~ SwaggerNull
381375 go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
376+ & type_ .~ SwaggerBoolean
383377 & enum_ ?~ [js]
384378 go js@(String s) = mempty
385− & type_ ?~ SwaggerString
379+ & type_ .~ SwaggerString
386380 & maxLength ?~ fromIntegral (T.length s)
387381 & minLength ?~ fromIntegral (T.length s)
388382 & pattern ?~ s
389383 & enum_ ?~ [js]
390384 go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
385+ & type_ .~ SwaggerNumber
392386 & maximum_ ?~ n
393387 & minimum_ ?~ n
394388 & multipleOf ?~ n
395389 & enum_ ?~ [js]
396390 go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
391+ & type_ .~ SwaggerArray
398392 & maxItems ?~ fromIntegral sz
399393 & minItems ?~ fromIntegral sz
400394 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -404,7 +398,7 @@ sketchStrictSchema = go . toJSON
404398 sz = length xs
405399 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406400 go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
401+ & type_ .~ SwaggerObject
408402 & required .~ names
409403 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410404 & maxProperties ?~ fromIntegral (length names)
@@ -414,13 +408,13 @@ sketchStrictSchema = go . toJSON
414408 names = HashMap.keys o
415409
416410class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
411+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418412
419413instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420414 declareNamedSchema _ = do
421415 ref <- declareSchemaRef (Proxy :: Proxy a)
422416 return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
417+ & type_ .~ SwaggerArray
424418 & items ?~ SwaggerItemsObject ref
425419
426420instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
@@ -470,7 +464,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
470464
471465timeSchema :: T.Text -> Schema
472466timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
467+ & type_ .~ SwaggerString
474468 & format ?~ fmt
475469
476470-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -503,8 +497,6 @@ instance ToSchema UTCTime where
503497instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504498instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505499
506−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
507−
508500#if __GLASGOW_HASKELL__ < 800
509501#else
510502type family ToSchemaByteStringError bs where
@@ -532,8 +524,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
532524 declareObjectMapSchema = do
533525 schema <- declareSchemaRef (Proxy :: Proxy v)
534526 return $ unnamed $ mempty
535− & type_ ?~ SwaggerObject
536− & additionalProperties ?~ AdditionalPropertiesSchema schema
527+ & type_ .~ SwaggerObject
528+ & additionalProperties ?~ schema
537529
538530instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
539531 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
@@ -544,7 +536,7 @@ instance ToSchema a => ToSchema (Map String a) where
544536 declareNamedSchema _ = do
545537 schema <- declareSchemaRef (Proxy :: Proxy a)
546538 return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
539+ & type_ .~ SwaggerObject
548540 & additionalProperties ?~ schema
549541
550542instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -556,12 +548,6 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =
556548
557549#endif
558550
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−
565551instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566552instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567553instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -575,13 +561,6 @@ instance ToSchema a => ToSchema (Set a) where
575561
576562instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577563
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−
585564instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586565instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587566
@@ -597,26 +576,26 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar
597576--
598577-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599578-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
579+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
601580toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
581+ & type_ .~ SwaggerInteger
603582 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604583 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605584
606585-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
586+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
608587 ( Bounded a, Integral a
609588 , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
589+ => SchemaOptions -> proxy a -> NamedSchema
611590genericToNamedSchemaBoundedIntegral opts proxy
612591 = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
613592
614593-- | Declare a named schema for a @newtype@ wrapper.
615−genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
594+genericDeclareNamedSchemaNewtype :: forall proxy a d c s i inner.
616595 (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617596 => SchemaOptions -- ^ How to derive the name.
618597 -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619− -> Proxy a
598+ -> proxy a
620599 -> Declare (Definitions Schema) NamedSchema
621600genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622601
@@ -633,9 +612,9 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$>
633612--
634613-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635614-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636−declareSchemaBoundedEnumKeyMapping :: forall map key value.
615+declareSchemaBoundedEnumKeyMapping :: forall map key value proxy.
637616 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638− => Proxy (map key value) -> Declare (Definitions Schema) Schema
617+ => proxy (map key value) -> Declare (Definitions Schema) Schema
639618declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640619 ToJSONKeyText keyToText _ -> objectSchema keyToText
641620 ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
@@ -645,7 +624,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
645624 let allKeys = [minBound..maxBound :: key]
646625 mkPair k = (keyToText k, valueRef)
647626 return $ mempty
648− & type_ ?~ SwaggerObject
627+ & type_ .~ SwaggerObject
649628 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650629
651630-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
@@ -661,71 +640,71 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o
661640--
662641-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663642-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664−toSchemaBoundedEnumKeyMapping :: forall map key value.
643+toSchemaBoundedEnumKeyMapping :: forall map key value proxy.
665644 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666− => Proxy (map key value) -> Schema
645+ => proxy (map key value) -> Schema
667646toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
668647
669648-- | A configurable generic @'Schema'@ creator.
670649genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
650+ SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
672651genericDeclareSchema = genericDeclareSchemaUnrestricted
673652
674653-- | A configurable generic @'NamedSchema'@ creator.
675654-- This function applied to @'defaultSchemaOptions'@
676655-- is used as the default for @'declareNamedSchema'@
677656-- when the type is an instance of @'Generic'@.
678−genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
679− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
657+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
658+ SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
680659genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
681660
682661-- | A configurable generic @'Schema'@ creator.
683662--
684663-- Unlike 'genericDeclareSchema' also works for mixed sum types.
685664-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
686−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
665+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
687666genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
688667
689668-- | A configurable generic @'NamedSchema'@ creator.
690669--
691670-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
692671-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
693−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
694− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
672+genericDeclareNamedSchemaUnrestricted :: forall a proxy. (Generic a, GToSchema (Rep a)) =>
673+ SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
695674genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
696675
697676-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698−genericNameSchema :: forall a d f.
677+genericNameSchema :: forall a d f proxy.
699678 (Generic a, Rep a ~ D1 d f, Datatype d)
700− => SchemaOptions -> Proxy a -> Schema -> NamedSchema
679+ => SchemaOptions -> proxy a -> Schema -> NamedSchema
701680genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
702681
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
682+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
683+gdatatypeSchemaName opts _ = case name of
705684 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706685 _ -> Nothing
707686 where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
709− name = datatypeNameModifier opts orig
687+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
710688
711689-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
713− SchemaOptions -> Proxy a -> NamedSchema
690+paramSchemaToNamedSchema :: forall a d f proxy.
691+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
692+ => SchemaOptions -> proxy a -> NamedSchema
714693paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
715694
716695-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
696+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
697+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
719698
720699nullarySchema :: Schema
721700nullarySchema = mempty
722− & type_ ?~ SwaggerArray
701+ & type_ .~ SwaggerArray
723702 & items ?~ SwaggerItemsArray []
724703
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
704+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
726705gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727706
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
707+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
729708gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730709
731710instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -745,7 +724,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745724 gdeclareNamedSchema = gdeclareNamedSumSchema
746725
747726-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
727+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
749728 gdeclareNamedSchema opts _ s
750729 | unwrapUnaryRecords opts = fieldSchema
751730 | otherwise =
@@ -759,7 +738,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
759738 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760739 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761740
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
741+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
763742gdeclareSchemaRef opts proxy = do
764743 case gtoNamedSchema opts proxy of
765744 NamedSchema (Just name) schema -> do
@@ -790,12 +769,12 @@ withFieldSchema opts _ isRequiredField schema = do
790769 return $
791770 if T.null fname
792771 then schema
793− & type_ ?~ SwaggerArray
772+ & type_ .~ SwaggerArray
794773 & items %~ appendItem ref
795774 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796775 & minItems %~ Just . maybe 1 (+1) -- increment minItems
797776 else schema
798− & type_ ?~ SwaggerObject
777+ & type_ .~ SwaggerObject
799778 & properties . at fname ?~ ref
800779 & if isRequiredField
801780 then required %~ (++ [fname])
@@ -823,7 +802,7 @@ instance ( GSumToSchema f
823802 where
824803 gdeclareNamedSchema = gdeclareNamedSumSchema
825804
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
805+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827806gdeclareNamedSumSchema opts proxy s
828807 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829808 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -832,29 +811,29 @@ gdeclareNamedSumSchema opts proxy s
832811 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833812
834813 toStringTag schema = mempty
835− & type_ ?~ SwaggerString
814+ & type_ .~ SwaggerString
836815 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837816
838817type AllNullary = All
839818
840819class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
820+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842821
843822instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844823 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
845824
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
825+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
826+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
848827gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
828+ & type_ .~ SwaggerObject
850829 & properties . at tag ?~ ref
851830 & maxProperties ?~ 1
852831 & minProperties ?~ 1
853832 where
854833 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855834
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
835+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
836+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858837gsumConToSchema opts proxy schema = do
859838 ref <- gdeclareSchemaRef opts proxy
860839 return $ gsumConToSchemaWith ref opts proxy schema
src/Data/Swagger/Internal/Schema/Validation.hs+50−212
@@ -1,17 +1,15 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE GADTs #-}
75{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE PackageImports #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE UndecidableInstances #-}
1513-- |
1614-- Module: Data.Swagger.Internal.Schema.Validation
1715-- Copyright: (c) 2015 GetShopTV
@@ -22,34 +20,28 @@
2220-- Validate JSON values with Swagger Schema.
2321module Data.Swagger.Internal.Schema.Validation where
2422
25−import Prelude ()
26−import Prelude.Compat
23+import Control.Applicative
24+import Control.Lens
25+import Control.Monad (when)
2726
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
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
3931import qualified "unordered-containers" Data.HashSet as HashSet
40−import Data.Proxy
41−import Data.Scientific (Scientific, isInteger)
42−import Data.Text (Text)
43−import qualified Data.Text as Text
44−import qualified Data.Text.Lazy as TL
45−import qualified Data.Text.Lazy.Encoding as TL
46−import Data.Vector (Vector)
47−import qualified Data.Vector as Vector
48−
49−import Data.Swagger.Declare
50−import Data.Swagger.Internal
51−import Data.Swagger.Internal.Schema
52−import Data.Swagger.Lens
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
5345
5446-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
5547-- This can be used with QuickCheck to ensure those instances are coherent:
@@ -58,101 +50,18 @@ import Data.Swagger.Lens
5850--
5951-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
6052-- See @'validateToJSONWithPatternChecker'@.
61−--
62−-- See 'renderValidationErrors' on how the output is structured.
63−validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String
64−validatePrettyToJSON = renderValidationErrors validateToJSON
65−
66−-- | Variant of 'validatePrettyToJSON' with typed output.
6753validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
6854validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
6955
7056-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
7157-- This can be used with QuickCheck to ensure those instances are coherent.
7258--
73−-- For validation without patterns see @'validateToJSON'@. See also:
74−-- 'renderValidationErrors'.
59+-- For validation without patterns see @'validateToJSON'@.
7560validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
7661validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
7762 where
7863 (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
7964
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−
15665-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
15766--
15867-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
@@ -403,16 +312,12 @@ validateObject o = withSchema $ \sch ->
403312 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
404313 _ ->
405314 case InsOrdHashMap.lookup k (sch ^. properties) of
406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
315+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ \s -> validateWithSchemaRef s v
407316 Just s -> validateWithSchemaRef s v
408317
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−
413318 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"
319+ unknownProperty name = invalid $
320+ "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema"
416321
417322validateEnum :: Value -> Validation (ParamSchema t) ()
418323validateEnum value = do
@@ -420,92 +325,25 @@ validateEnum value = do
420325 when (value `notElem` xs) $
421326 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
422327
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−
470328validateSchemaType :: Value -> Validation Schema ()
471329validateSchemaType value = withSchema $ \sch ->
472330 case (sch ^. type_, value) of
473− (Just SwaggerNull, Null) -> valid
474− (Just SwaggerBoolean, Bool _) -> valid
475− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
476− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
477− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
478− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
479− (Just SwaggerObject, Object o) -> validateObject o
480− (Nothing, Null) -> valid
481− (Nothing, Bool _) -> valid
482− -- Number by default
483− (Nothing, Number n) -> sub_ paramSchema (validateNumber n)
484− (Nothing, String s) -> sub_ paramSchema (validateString s)
485− (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
486− (Nothing, Object o) -> validateObject o
487− bad -> invalid $ "expected JSON value of type " ++ showType bad
331+ (SwaggerNull, Null) -> valid
332+ (SwaggerBoolean, Bool _) -> valid
333+ (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
334+ (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
335+ (SwaggerString, String s) -> sub_ paramSchema (validateString s)
336+ (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
337+ (SwaggerObject, Object o) -> validateObject o
338+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
488339
489340validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
490341validateParamSchemaType value = withSchema $ \sch ->
491342 case (sch ^. type_, value) of
492− (Just SwaggerBoolean, Bool _) -> valid
493− (Just SwaggerInteger, Number n) -> validateInteger n
494− (Just SwaggerNumber, Number n) -> validateNumber n
495− (Just SwaggerString, String s) -> validateString s
496− (Just SwaggerArray, Array xs) -> validateArray xs
497− (Nothing, Bool _) -> valid
498− -- Number by default
499− (Nothing, Number n) -> validateNumber n
500− (Nothing, String s) -> validateString s
501− (Nothing, Array xs) -> validateArray xs
502− bad -> invalid $ "expected JSON value of type " ++ showType bad
503−
504−showType :: (Maybe (SwaggerType t), Value) -> String
505−showType (Just type_, _) = show type_
506−showType (Nothing, Null) = "SwaggerNull"
507−showType (Nothing, Bool _) = "SwaggerBoolean"
508−showType (Nothing, Number _) = "SwaggerNumber"
509−showType (Nothing, String _) = "SwaggerString"
510−showType (Nothing, Array _) = "SwaggerArray"
511−showType (Nothing, Object _) = "SwaggerObject"
343+ (SwaggerBoolean, Bool _) -> valid
344+ (SwaggerInteger, Number n) -> validateInteger n
345+ (SwaggerNumber, Number n) -> validateNumber n
346+ (SwaggerString, String s) -> validateString s
347+ (SwaggerArray, Array xs) -> validateArray xs
348+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
349+
src/Data/Swagger/Internal/Utils.hs+1
@@ -21,6 +21,7 @@ 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
2425import Data.Set (Set)
2526import Data.Text (Text)
2627import GHC.Generics
src/Data/Swagger/Lens.hs+4−10
@@ -96,19 +96,13 @@ 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−
10599instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
106100
107101-- HasType instances
108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_
109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_
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_
112106
113107-- HasDefault instances
114108instance 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.Proxy
40+import Data.Monoid
4141import qualified Data.Set as Set
4242
4343import Data.Swagger.Declare
@@ -46,7 +46,6 @@ 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
5049
5150-- $setup
5251-- >>> import Data.Aeson
@@ -112,15 +111,15 @@ applyTags = applyTagsFor allOperations
112111-- list of tags.
113112applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
114113applyTagsFor ops ts swag = swag
115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
116− & tags %~ (<> InsOrdHS.fromList ts)
114+ & ops . tags %~ (<> Set.fromList (map _tagName ts))
115+ & tags %~ (<> Set.fromList ts)
117116
118117-- | Construct a response with @'Schema'@ while declaring all
119118-- necessary schema definitions.
120119--
121120-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122121-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
123−declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response
122+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
124123declareResponse proxy = do
125124 s <- declareSchemaRef proxy
126125 return (mempty & schema ?~ s)
@@ -191,3 +190,4 @@ setResponseForWith ops f code dres swag = swag
191190 Nothing -> new -- response name can't be dereferenced, replacing with new response
192191 combine (Just (Inline old)) = f old new
193192 combine Nothing = new
193+
src/Data/Swagger/Optics.hsdeleted−597
@@ -1,597 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE OverloadedLabels #-}
5−{-# LANGUAGE TemplateHaskell #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−{-# OPTIONS_GHC -fno-warn-orphans #-}
9−-- |
10−-- Module: Data.Swagger.Optics
11−-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>
12−-- Stability: experimental
13−--
14−-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>
15−-- library.
16−--
17−-- >>> import Data.Aeson
18−-- >>> import Optics.Core
19−-- >>> :set -XOverloadedLabels
20−--
21−-- Example from the "Data.Swagger" module using @optics@:
22−--
23−-- >>> :{
24−-- encode $ (mempty :: Swagger)
25−-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]
26−-- & #paths .~
27−-- [ ("/user", mempty & #get ?~ (mempty
28−-- & #produces ?~ MimeList ["application/json"]
29−-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))
30−-- & at 404 ?~ "User info not found")) ]
31−-- :}
32−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"
33−--
34−-- For convenience optics are defined as /labels/. It means that field accessor
35−-- names can be overloaded for different types. One such common field is
36−-- @#description@. Many components of a Swagger specification can have
37−-- descriptions, and you can use the same name for them:
38−--
39−-- >>> encode $ (mempty :: Response) & #description .~ "No content"
40−-- "{\"description\":\"No content\"}"
41−-- >>> :{
42−-- encode $ (mempty :: Schema)
43−-- & #type ?~ SwaggerBoolean
44−-- & #description ?~ "To be or not to be"
45−-- :}
46−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
47−--
48−-- @'ParamSchema'@ is basically the /base schema specification/ and many types
49−-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively
50−-- made fields of the type that has it. For example, you can use @#type@ to
51−-- access @'SwaggerType'@ of @'Header'@ schema without having to use
52−-- @#paramSchema@:
53−--
54−-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber
55−-- "{\"type\":\"number\"}"
56−--
57−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and
58−-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:
59−--
60−-- >>> :{
61−-- encode $ (mempty :: Operation)
62−-- & at 404 ?~ "Not found"
63−-- :}
64−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"
65−--
66−module Data.Swagger.Optics () where
67−
68−import Data.Aeson (Value)
69−import Data.Scientific (Scientific)
70−import Data.Swagger.Internal
71−import Data.Text (Text)
72−import Optics.Core
73−import Optics.TH
74−
75−-- Lenses
76−
77−makeFieldLabels ''Swagger
78−makeFieldLabels ''Host
79−makeFieldLabels ''Info
80−makeFieldLabels ''Contact
81−makeFieldLabels ''License
82−makeFieldLabels ''PathItem
83−makeFieldLabels ''Tag
84−makeFieldLabels ''Operation
85−makeFieldLabels ''Param
86−makeFieldLabels ''ParamOtherSchema
87−makeFieldLabels ''Header
88−makeFieldLabels ''Schema
89−makeFieldLabels ''NamedSchema
90−makeFieldLabels ''ParamSchema
91−makeFieldLabels ''Xml
92−makeFieldLabels ''Responses
93−makeFieldLabels ''Response
94−makeFieldLabels ''SecurityScheme
95−makeFieldLabels ''ApiKeyParams
96−makeFieldLabels ''OAuth2Params
97−makeFieldLabels ''ExternalDocs
98−
99−-- Prisms
100−
101−makePrismLabels ''ParamAnySchema
102−makePrismLabels ''SecuritySchemeType
103−makePrismLabels ''Referenced
104−
105−-- SwaggerItems prisms
106−
107−instance
108− ( a ~ [Referenced Schema]
109− , b ~ [Referenced Schema]
110− ) => LabelOptic "_SwaggerItemsArray"
111− A_Review
112− (SwaggerItems 'SwaggerKindSchema)
113− (SwaggerItems 'SwaggerKindSchema)
114− a
115− b where
116− labelOptic = unto (\x -> SwaggerItemsArray x)
117− {-# INLINE labelOptic #-}
118−
119−instance
120− ( a ~ Referenced Schema
121− , b ~ Referenced Schema
122− ) => LabelOptic "_SwaggerItemsObject"
123− A_Review
124− (SwaggerItems 'SwaggerKindSchema)
125− (SwaggerItems 'SwaggerKindSchema)
126− a
127− b where
128− labelOptic = unto (\x -> SwaggerItemsObject x)
129− {-# INLINE labelOptic #-}
130−
131−instance
132− ( a ~ (Maybe (CollectionFormat t), ParamSchema t)
133− , b ~ (Maybe (CollectionFormat t), ParamSchema t)
134− ) => LabelOptic "_SwaggerItemsPrimitive"
135− A_Review
136− (SwaggerItems t)
137− (SwaggerItems t)
138− a
139− b where
140− labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)
141− {-# INLINE labelOptic #-}
142−
143−-- =============================================================
144−-- More helpful instances for easier access to schema properties
145−
146−type instance Index Responses = HttpStatusCode
147−type instance Index Operation = HttpStatusCode
148−
149−type instance IxValue Responses = Referenced Response
150−type instance IxValue Operation = Referenced Response
151−
152−instance Ixed Responses where
153− ix n = #responses % ix n
154− {-# INLINE ix #-}
155−instance At Responses where
156− at n = #responses % at n
157− {-# INLINE at #-}
158−
159−instance Ixed Operation where
160− ix n = #responses % ix n
161− {-# INLINE ix #-}
162−instance At Operation where
163− at n = #responses % at n
164− {-# INLINE at #-}
165−
166−-- #paramSchema
167−
168−instance
169− ( a ~ ParamSchema 'SwaggerKindSchema
170− , b ~ ParamSchema 'SwaggerKindSchema
171− ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where
172− labelOptic = #schema % #paramSchema
173− {-# INLINE labelOptic #-}
174−
175−-- #type
176−
177−instance
178− ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
179− , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))
180− ) => LabelOptic "type" A_Lens Header Header a b where
181− labelOptic = #paramSchema % #type
182− {-# INLINE labelOptic #-}
183−
184−instance
185− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
186− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
187− ) => LabelOptic "type" A_Lens Schema Schema a b where
188− labelOptic = #paramSchema % #type
189− {-# INLINE labelOptic #-}
190−
191−instance
192− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)
193− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)
194− ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where
195− labelOptic = #paramSchema % #type
196− {-# INLINE labelOptic #-}
197−
198−instance
199− ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
200− , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)
201− ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where
202− labelOptic = #paramSchema % #type
203− {-# INLINE labelOptic #-}
204−
205−-- #default
206−
207−instance
208− ( a ~ Maybe Value, b ~ Maybe Value
209− ) => LabelOptic "default" A_Lens Header Header a b where
210− labelOptic = #paramSchema % #default
211− {-# INLINE labelOptic #-}
212−
213−instance
214− ( a ~ Maybe Value, b ~ Maybe Value
215− ) => LabelOptic "default" A_Lens Schema Schema a b where
216− labelOptic = #paramSchema % #default
217− {-# INLINE labelOptic #-}
218−
219−instance
220− ( a ~ Maybe Value, b ~ Maybe Value
221− ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where
222− labelOptic = #paramSchema % #default
223− {-# INLINE labelOptic #-}
224−
225−instance
226− ( a ~ Maybe Value, b ~ Maybe Value
227− ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where
228− labelOptic = #paramSchema % #default
229− {-# INLINE labelOptic #-}
230−
231−-- #format
232−
233−instance
234− ( a ~ Maybe Format, b ~ Maybe Format
235− ) => LabelOptic "format" A_Lens Header Header a b where
236− labelOptic = #paramSchema % #format
237− {-# INLINE labelOptic #-}
238−
239−instance
240− ( a ~ Maybe Format, b ~ Maybe Format
241− ) => LabelOptic "format" A_Lens Schema Schema a b where
242− labelOptic = #paramSchema % #format
243− {-# INLINE labelOptic #-}
244−
245−instance
246− ( a ~ Maybe Format, b ~ Maybe Format
247− ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where
248− labelOptic = #paramSchema % #format
249− {-# INLINE labelOptic #-}
250−
251−instance
252− ( a ~ Maybe Format, b ~ Maybe Format
253− ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where
254− labelOptic = #paramSchema % #format
255− {-# INLINE labelOptic #-}
256−
257−-- #items
258−
259−instance
260− ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
261− , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))
262− ) => LabelOptic "items" A_Lens Header Header a b where
263− labelOptic = #paramSchema % #items
264− {-# INLINE labelOptic #-}
265−
266−instance
267− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
268− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
269− ) => LabelOptic "items" A_Lens Schema Schema a b where
270− labelOptic = #paramSchema % #items
271− {-# INLINE labelOptic #-}
272−
273−instance
274− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)
275− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)
276− ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where
277− labelOptic = #paramSchema % #items
278− {-# INLINE labelOptic #-}
279−
280−instance
281− ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
282− , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)
283− ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where
284− labelOptic = #paramSchema % #items
285− {-# INLINE labelOptic #-}
286−
287−-- #maximum
288−
289−instance
290− ( a ~ Maybe Scientific, b ~ Maybe Scientific
291− ) => LabelOptic "maximum" A_Lens Header Header a b where
292− labelOptic = #paramSchema % #maximum
293− {-# INLINE labelOptic #-}
294−
295−instance
296− ( a ~ Maybe Scientific, b ~ Maybe Scientific
297− ) => LabelOptic "maximum" A_Lens Schema Schema a b where
298− labelOptic = #paramSchema % #maximum
299− {-# INLINE labelOptic #-}
300−
301−instance
302− ( a ~ Maybe Scientific, b ~ Maybe Scientific
303− ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where
304− labelOptic = #paramSchema % #maximum
305− {-# INLINE labelOptic #-}
306−
307−instance
308− ( a ~ Maybe Scientific, b ~ Maybe Scientific
309− ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
310− labelOptic = #paramSchema % #maximum
311− {-# INLINE labelOptic #-}
312−
313−-- #exclusiveMaximum
314−
315−instance
316− ( a ~ Maybe Bool, b ~ Maybe Bool
317− ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where
318− labelOptic = #paramSchema % #exclusiveMaximum
319− {-# INLINE labelOptic #-}
320−
321−instance
322− ( a ~ Maybe Bool, b ~ Maybe Bool
323− ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where
324− labelOptic = #paramSchema % #exclusiveMaximum
325− {-# INLINE labelOptic #-}
326−
327−instance
328− ( a ~ Maybe Bool, b ~ Maybe Bool
329− ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where
330− labelOptic = #paramSchema % #exclusiveMaximum
331− {-# INLINE labelOptic #-}
332−
333−instance
334− ( a ~ Maybe Bool, b ~ Maybe Bool
335− ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where
336− labelOptic = #paramSchema % #exclusiveMaximum
337− {-# INLINE labelOptic #-}
338−
339−-- #minimum
340−
341−instance
342− ( a ~ Maybe Scientific, b ~ Maybe Scientific
343− ) => LabelOptic "minimum" A_Lens Header Header a b where
344− labelOptic = #paramSchema % #minimum
345− {-# INLINE labelOptic #-}
346−
347−instance
348− ( a ~ Maybe Scientific, b ~ Maybe Scientific
349− ) => LabelOptic "minimum" A_Lens Schema Schema a b where
350− labelOptic = #paramSchema % #minimum
351− {-# INLINE labelOptic #-}
352−
353−instance
354− ( a ~ Maybe Scientific, b ~ Maybe Scientific
355− ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where
356− labelOptic = #paramSchema % #minimum
357− {-# INLINE labelOptic #-}
358−
359−instance
360− ( a ~ Maybe Scientific, b ~ Maybe Scientific
361− ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
362− labelOptic = #paramSchema % #minimum
363− {-# INLINE labelOptic #-}
364−
365−-- #exclusiveMinimum
366−
367−instance
368− ( a ~ Maybe Bool, b ~ Maybe Bool
369− ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where
370− labelOptic = #paramSchema % #exclusiveMinimum
371− {-# INLINE labelOptic #-}
372−
373−instance
374− ( a ~ Maybe Bool, b ~ Maybe Bool
375− ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where
376− labelOptic = #paramSchema % #exclusiveMinimum
377− {-# INLINE labelOptic #-}
378−
379−instance
380− ( a ~ Maybe Bool, b ~ Maybe Bool
381− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where
382− labelOptic = #paramSchema % #exclusiveMinimum
383− {-# INLINE labelOptic #-}
384−
385−instance
386− ( a ~ Maybe Bool, b ~ Maybe Bool
387− ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where
388− labelOptic = #paramSchema % #exclusiveMinimum
389− {-# INLINE labelOptic #-}
390−
391−-- #maxLength
392−
393−instance
394− ( a ~ Maybe Integer, b ~ Maybe Integer
395− ) => LabelOptic "maxLength" A_Lens Header Header a b where
396− labelOptic = #paramSchema % #maxLength
397− {-# INLINE labelOptic #-}
398−
399−instance
400− ( a ~ Maybe Integer, b ~ Maybe Integer
401− ) => LabelOptic "maxLength" A_Lens Schema Schema a b where
402− labelOptic = #paramSchema % #maxLength
403− {-# INLINE labelOptic #-}
404−
405−instance
406− ( a ~ Maybe Integer, b ~ Maybe Integer
407− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where
408− labelOptic = #paramSchema % #maxLength
409− {-# INLINE labelOptic #-}
410−
411−instance
412− ( a ~ Maybe Integer, b ~ Maybe Integer
413− ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
414− labelOptic = #paramSchema % #maxLength
415− {-# INLINE labelOptic #-}
416−
417−-- #minLength
418−
419−instance
420− ( a ~ Maybe Integer, b ~ Maybe Integer
421− ) => LabelOptic "minLength" A_Lens Header Header a b where
422− labelOptic = #paramSchema % #minLength
423− {-# INLINE labelOptic #-}
424−
425−instance
426− ( a ~ Maybe Integer, b ~ Maybe Integer
427− ) => LabelOptic "minLength" A_Lens Schema Schema a b where
428− labelOptic = #paramSchema % #minLength
429− {-# INLINE labelOptic #-}
430−
431−instance
432− ( a ~ Maybe Integer, b ~ Maybe Integer
433− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where
434− labelOptic = #paramSchema % #minLength
435− {-# INLINE labelOptic #-}
436−
437−instance
438− ( a ~ Maybe Integer, b ~ Maybe Integer
439− ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where
440− labelOptic = #paramSchema % #minLength
441− {-# INLINE labelOptic #-}
442−
443−-- #pattern
444−
445−instance
446− ( a ~ Maybe Text, b ~ Maybe Text
447− ) => LabelOptic "pattern" A_Lens Header Header a b where
448− labelOptic = #paramSchema % #pattern
449− {-# INLINE labelOptic #-}
450−
451−instance
452− ( a ~ Maybe Text, b ~ Maybe Text
453− ) => LabelOptic "pattern" A_Lens Schema Schema a b where
454− labelOptic = #paramSchema % #pattern
455− {-# INLINE labelOptic #-}
456−
457−instance
458− ( a ~ Maybe Text, b ~ Maybe Text
459− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where
460− labelOptic = #paramSchema % #pattern
461− {-# INLINE labelOptic #-}
462−
463−instance
464− ( a ~ Maybe Text, b ~ Maybe Text
465− ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where
466− labelOptic = #paramSchema % #pattern
467− {-# INLINE labelOptic #-}
468−
469−-- #maxItems
470−
471−instance
472− ( a ~ Maybe Integer, b ~ Maybe Integer
473− ) => LabelOptic "maxItems" A_Lens Header Header a b where
474− labelOptic = #paramSchema % #maxItems
475− {-# INLINE labelOptic #-}
476−
477−instance
478− ( a ~ Maybe Integer, b ~ Maybe Integer
479− ) => LabelOptic "maxItems" A_Lens Schema Schema a b where
480− labelOptic = #paramSchema % #maxItems
481− {-# INLINE labelOptic #-}
482−
483−instance
484− ( a ~ Maybe Integer, b ~ Maybe Integer
485− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where
486− labelOptic = #paramSchema % #maxItems
487− {-# INLINE labelOptic #-}
488−
489−instance
490− ( a ~ Maybe Integer, b ~ Maybe Integer
491− ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
492− labelOptic = #paramSchema % #maxItems
493− {-# INLINE labelOptic #-}
494−
495−-- #minItems
496−
497−instance
498− ( a ~ Maybe Integer, b ~ Maybe Integer
499− ) => LabelOptic "minItems" A_Lens Header Header a b where
500− labelOptic = #paramSchema % #minItems
501− {-# INLINE labelOptic #-}
502−
503−instance
504− ( a ~ Maybe Integer, b ~ Maybe Integer
505− ) => LabelOptic "minItems" A_Lens Schema Schema a b where
506− labelOptic = #paramSchema % #minItems
507− {-# INLINE labelOptic #-}
508−
509−instance
510− ( a ~ Maybe Integer, b ~ Maybe Integer
511− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where
512− labelOptic = #paramSchema % #minItems
513− {-# INLINE labelOptic #-}
514−
515−instance
516− ( a ~ Maybe Integer, b ~ Maybe Integer
517− ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
518− labelOptic = #paramSchema % #minItems
519− {-# INLINE labelOptic #-}
520−
521−-- #uniqueItems
522−
523−instance
524− ( a ~ Maybe Bool, b ~ Maybe Bool
525− ) => LabelOptic "uniqueItems" A_Lens Header Header a b where
526− labelOptic = #paramSchema % #uniqueItems
527− {-# INLINE labelOptic #-}
528−
529−instance
530− ( a ~ Maybe Bool, b ~ Maybe Bool
531− ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where
532− labelOptic = #paramSchema % #uniqueItems
533− {-# INLINE labelOptic #-}
534−
535−instance
536− ( a ~ Maybe Bool, b ~ Maybe Bool
537− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where
538− labelOptic = #paramSchema % #uniqueItems
539− {-# INLINE labelOptic #-}
540−
541−instance
542− ( a ~ Maybe Bool, b ~ Maybe Bool
543− ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where
544− labelOptic = #paramSchema % #uniqueItems
545− {-# INLINE labelOptic #-}
546−
547−-- #enum
548−
549−instance
550− ( a ~ Maybe [Value], b ~ Maybe [Value]
551− ) => LabelOptic "enum" A_Lens Header Header a b where
552− labelOptic = #paramSchema % #enum
553− {-# INLINE labelOptic #-}
554−
555−instance
556− ( a ~ Maybe [Value], b ~ Maybe [Value]
557− ) => LabelOptic "enum" A_Lens Schema Schema a b where
558− labelOptic = #paramSchema % #enum
559− {-# INLINE labelOptic #-}
560−
561−instance
562− ( a ~ Maybe [Value], b ~ Maybe [Value]
563− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where
564− labelOptic = #paramSchema % #enum
565− {-# INLINE labelOptic #-}
566−
567−instance
568− ( a ~ Maybe [Value], b ~ Maybe [Value]
569− ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where
570− labelOptic = #paramSchema % #enum
571− {-# INLINE labelOptic #-}
572−
573−-- #multipleOf
574−
575−instance
576− ( a ~ Maybe Scientific, b ~ Maybe Scientific
577− ) => LabelOptic "multipleOf" A_Lens Header Header a b where
578− labelOptic = #paramSchema % #multipleOf
579− {-# INLINE labelOptic #-}
580−
581−instance
582− ( a ~ Maybe Scientific, b ~ Maybe Scientific
583− ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where
584− labelOptic = #paramSchema % #multipleOf
585− {-# INLINE labelOptic #-}
586−
587−instance
588− ( a ~ Maybe Scientific, b ~ Maybe Scientific
589− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where
590− labelOptic = #paramSchema % #multipleOf
591− {-# INLINE labelOptic #-}
592−
593−instance
594− ( a ~ Maybe Scientific, b ~ Maybe Scientific
595− ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where
596− labelOptic = #paramSchema % #multipleOf
597− {-# INLINE labelOptic #-}
src/Data/Swagger/Schema.hs−1
@@ -54,7 +54,6 @@ module Data.Swagger.Schema (
5454 -- * Generic encoding configuration
5555 SchemaOptions(..),
5656 defaultSchemaOptions,
57− fromAesonOptions,
5857) where
5958
6059import Data.Swagger.Internal.Schema
src/Data/Swagger/Schema/Generator.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.Schema.Generator where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens.Operators
11−import Control.Monad (filterM)
12−import Data.Aeson
13−import Data.Aeson.Types
14−import qualified Data.HashMap.Strict.InsOrd as M
15−import Data.Maybe
16−import Data.Maybe
17−import Data.Proxy
18−import Data.Scientific
19−import qualified Data.Set as S
20−import Data.Swagger
21−import Data.Swagger.Declare
22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)
23−import qualified Data.Text as T
24−import qualified Data.Vector as V
25−import Test.QuickCheck (arbitrary)
26−import Test.QuickCheck.Gen
27−import Test.QuickCheck.Property
28−
29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30−-- and cannot be inferred.
31−schemaGen :: Definitions Schema -> Schema -> Gen Value
32−schemaGen _ schema
33− | Just cases <- schema ^. paramSchema . enum_ = elements cases
34−schemaGen defns schema =
35− case schema ^. type_ of
36− Nothing ->
37− case inferSchemaTypes schema of
38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
39− -- Gen is not MonadFail
40− _ -> error "unable to infer schema type"
41− Just SwaggerBoolean -> Bool <$> elements [True, False]
42− Just SwaggerNull -> pure Null
43− Just SwaggerNumber
44− | Just min <- schema ^. minimum_
45− , Just max <- schema ^. maximum_ ->
46− Number . fromFloatDigits <$>
47− choose (toRealFloat min, toRealFloat max :: Double)
48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
49− Just SwaggerInteger
50− | Just min <- schema ^. minimum_
51− , Just max <- schema ^. maximum_ ->
52− Number . fromInteger <$>
53− choose (truncate min, truncate max)
54− | otherwise -> Number . fromInteger <$> arbitrary
55− Just SwaggerArray
56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
57− | Just items <- schema ^. items ->
58− case items of
59− SwaggerItemsObject ref -> do
60− size <- getSize
61− let itemSchema = dereference defns ref
62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
64− arrayLength <- choose (minLength', max minLength' maxLength')
65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
66− return . Array $ V.fromList generatedArray
67− SwaggerItemsArray refs ->
68− let itemGens = schemaGen defns . dereference defns <$> refs
69− in fmap (Array . V.fromList) $ sequence itemGens
70− Just SwaggerString -> do
71− size <- getSize
72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
74− length <- choose (minLength', max minLength' maxLength')
75− str <- vectorOf length arbitrary
76− return . String $ T.pack str
77− Just SwaggerObject -> do
78− size <- getSize
79− let props = dereference defns <$> schema ^. properties
80− reqKeys = S.fromList $ schema ^. required
81− allKeys = S.fromList . M.keys $ schema ^. properties
82− optionalKeys = allKeys S.\\ reqKeys
83− minProps' = fromMaybe (length reqKeys) $
84− fromInteger <$> schema ^. minProperties
85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
86− shuffledOptional <- shuffle $ S.toList optionalKeys
87− numProps <- choose (minProps', max minProps' maxProps')
88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
90− let gens = schemaGen defns <$> presentProps
91− additionalGens <- case schema ^. additionalProperties of
92− Just (AdditionalPropertiesSchema addlSchema) -> do
93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
95− _ -> return []
96− x <- sequence $ gens <> additionalGens
97− return . Object $ M.toHashMap x
98− where
99− dereference :: Definitions a -> Referenced a -> a
100− dereference _ (Inline a) = a
101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
102−
103−genValue :: (ToSchema a) => Proxy a -> Gen Value
104−genValue p =
105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
106− in schemaGen defs schema
107−
108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
109−validateFromJSON p = forAll (genValue p) $
110− \val -> case parseEither parseJSON val of
111− Right (_ :: a) -> succeeded
112− Left err -> failed
113− { reason = err
114− }
src/Data/Swagger/Schema/Validation.hs−2
@@ -19,10 +19,8 @@ module Data.Swagger.Schema.Validation (
1919 ValidationError,
2020
2121 -- ** Using 'ToJSON' and 'ToSchema'
22− validatePrettyToJSON,
2322 validateToJSON,
2423 validateToJSONWithPatternChecker,
25− renderValidationErrors,
2624
2725 -- ** Using 'Value' and 'Schema'
2826 validateJSON,
src/Data/Swagger/SchemaOptions.hs−29
@@ -1,4 +1,3 @@
1−{-# LANGUAGE RecordWildCards #-}
21-- |
32-- Module: Data.Swagger.SchemaOptions
43-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -7,8 +6,6 @@
76-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
87module Data.Swagger.SchemaOptions where
98
10−import qualified Data.Aeson.Types as Aeson
11−
129-- | Options that specify how to encode your type to Swagger schema.
1310data SchemaOptions = SchemaOptions
1411 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
@@ -44,29 +41,3 @@ defaultSchemaOptions = SchemaOptions
4441 , unwrapUnaryRecords = False
4542 }
4643
47−-- | Convert 'Aeson.Options' to 'SchemaOptions'.
48−--
49−-- Specifically the following fields get copied:
50−--
51−-- * 'fieldLabelModifier'
52−-- * 'constructorTagModifier'
53−-- * 'allNullaryToStringTag'
54−-- * 'unwrapUnaryRecords'
55−--
56−-- Note that these fields have no effect on `SchemaOptions`:
57−--
58−-- * 'Aeson.omitNothingFields'
59−-- * 'Aeson.sumEncoding'
60−-- * 'Aeson.tagSingleConstructors'
61−--
62−-- The rest is defined as in 'defaultSchemaOptions'.
63−--
64−-- @since 2.2.1
65−--
66−fromAesonOptions :: Aeson.Options -> SchemaOptions
67−fromAesonOptions opts = defaultSchemaOptions
68− { fieldLabelModifier = Aeson.fieldLabelModifier opts
69− , constructorTagModifier = Aeson.constructorTagModifier opts
70− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts
71− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts
72− }
stack-ghc-8.0.yamlnew file+5
@@ -0,0 +1,5 @@
1+resolver: nightly-2016-05-29
2+packages:
3+- '.'
4+extra-deps:
5+ - aeson-0.11.2.1
stack-lts-2.yamlnew file+22
@@ -0,0 +1,22 @@
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+2−6
@@ -1,9 +1,5 @@
1−resolver: lts-14.3
1+resolver: lts-9.3
22packages:
33- '.'
44extra-deps:
5−- optics-core-0.2
6−- optics-th-0.2
7−- optics-extra-0.2
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3
5+- aeson-1.2.2.0
swagger2.cabal+50−84
@@ -1,15 +1,11 @@
1−cabal-version: >=1.10
21name: swagger2
3−version: 2.5
4−
2+version: 2.2
53synopsis: Swagger 2.0 data model
6−category: Web, Swagger
74description:
8− This library is intended to be used for decoding and encoding Swagger 2.0 API
5+ This library is inteded to be used for decoding and encoding Swagger 2.0 API
96 specifications as well as manipulating them.
107 .
118 The original Swagger 2.0 specification is available at http://swagger.io/specification/.
12−
139homepage: https://github.com/GetShopTV/swagger2
1410bug-reports: https://github.com/GetShopTV/swagger2/issues
1511license: BSD3
@@ -17,22 +13,19 @@ license-file: LICENSE
1713author: Nickolay Kudasov
1814maintainer: nickolay@getshoptv.com
1915copyright: (c) 2015-2016, GetShopTV
16+category: Web, Swagger
2017build-type: Custom
2118extra-source-files:
2219 README.md
2320 , CHANGELOG.md
2421 , examples/*.hs
2522 , include/overlapping-compat.h
26−tested-with:
27− GHC ==8.0.2
28− || ==8.2.2
29− || ==8.4.4
30− || ==8.6.5
31− || ==8.8.1
23+cabal-version: >=1.10
24+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1
3225
3326custom-setup
3427 setup-depends:
35− base, Cabal, cabal-doctest >=1.0.6 && <1.1
28+ base, Cabal, cabal-doctest >=1.0.2 && <1.1
3629
3730library
3831 hs-source-dirs: src
@@ -42,10 +35,8 @@ library
4235 Data.Swagger.Declare
4336 Data.Swagger.Lens
4437 Data.Swagger.Operation
45− Data.Swagger.Optics
4638 Data.Swagger.ParamSchema
4739 Data.Swagger.Schema
48− Data.Swagger.Schema.Generator
4940 Data.Swagger.Schema.Validation
5041 Data.Swagger.SchemaOptions
5142
@@ -57,89 +48,64 @@ library
5748 Data.Swagger.Internal.Utils
5849 Data.Swagger.Internal.AesonUtils
5950 Data.Swagger.Internal.TypeShape
60−
61− -- GHC boot libraries
62− build-depends:
63− base >=4.9 && <4.14
64− , aeson-pretty >=0.8.7 && <0.9
65− , bytestring >=0.10.4.0 && <0.11
66− , containers >=0.5.5.1 && <0.7
67− , template-haskell >=2.9.0.0 && <2.16
68− , time >=1.4.2 && <1.10
69− , transformers >=0.3.0.0 && <0.6
70−
71− build-depends:
72− mtl >=2.1 && <2.3
73− , text >=1.2.3.0 && <1.3
74−
75− -- other dependencies
76− build-depends:
77− base-compat-batteries >=0.10.4 && <0.12
78− , aeson >=1.4.2.0 && <1.5
79− -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
80− , cookie >=0.4.3 && <0.5
81− , generics-sop >=0.3.2.0 && <0.6
82− , hashable >=1.2.7.0 && <1.4
83− , http-media >=0.7.1.2 && <0.9
84− , insert-ordered-containers >=0.2.3 && <0.3
85− , lens >=4.16.1 && <4.19
86− , network >=2.6.3.5 && <3.2
87− , optics-core >=0.2 && <0.3
88− , optics-th >=0.2 && <0.3
89− , scientific >=0.3.6.2 && <0.4
90− , transformers-compat >=0.3 && <0.7
91− , unordered-containers >=0.2.9.0 && <0.3
92− , uuid-types >=1.0.3 && <1.1
93− , vector >=0.12.0.1 && <0.13
94− , QuickCheck >=2.10.1 && <2.14
95−
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
72+ if !impl(ghc >= 7.10)
73+ build-depends: nats >=1.1.1 && <1.2
9674 default-language: Haskell2010
9775
9876test-suite spec
9977 type: exitcode-stdio-1.0
10078 hs-source-dirs: test
10179 main-is: Spec.hs
102−
103− -- From library parat
10480 -- We need aeson's toEncoding for doctests too
105− build-depends:
106− base
107− , swagger2
108− , aeson
109− , base-compat-batteries
110− , bytestring
111− , containers
112− , hashable
113− , insert-ordered-containers
114− , lens
115− , mtl
116− , template-haskell
117− , text
118− , time
119− , unordered-containers
120− , vector
121− , QuickCheck
122−
123− -- test-suite only dependencies
124− build-depends:
125− hspec >=2.5.5 && <2.8
126− , HUnit >=1.6.0.0 && <1.7
127− , quickcheck-instances >=0.3.19 && <0.14
128− , utf8-string >=1.0.1.1 && <1.1
129−
130− -- https://github.com/haskell/cabal/issues/3708
131− build-tool-depends:
132− hspec-discover:hspec-discover >=2.5.5 && <2.8
133−
81+ build-depends: base
82+ , base-compat
83+ , aeson >=0.10.0.0
84+ , aeson-qq
85+ , bytestring
86+ , containers
87+ , hashable
88+ , hspec
89+ , insert-ordered-containers
90+ , HUnit
91+ , mtl
92+ , QuickCheck >=2.8.2
93+ , swagger2
94+ , text
95+ , time
96+ , unordered-containers
97+ , vector
98+ , lens
13499 other-modules:
135100 SpecCommon
136101 Data.SwaggerSpec
137− Data.Swagger.CommonTestTypes
138102 Data.Swagger.ParamSchemaSpec
139103 Data.Swagger.SchemaSpec
140104 Data.Swagger.Schema.ValidationSpec
141− Data.Swagger.Schema.GeneratorSpec
142105 default-language: Haskell2010
106+ -- https://github.com/haskell/cabal/issues/3708
107+ build-tool-depends:
108+ hspec-discover:hspec-discover
143109
144110test-suite doctests
145111 -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
test/Data/Swagger/CommonTestTypes.hsdeleted−679
@@ -1,679 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE QuasiQuotes #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.CommonTestTypes where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)
11−import Data.Aeson.QQ.Simple
12−import Data.Aeson.Types (toJSONKeyText)
13−import Data.Char
14−import Data.Map (Map)
15−import Data.Proxy
16−import Data.Set (Set)
17−import qualified Data.Text as Text
18−import GHC.Generics
19−
20−import Data.Swagger
21−
22−-- ========================================================================
23−-- Unit type
24−-- ========================================================================
25−
26−data Unit = Unit deriving (Generic)
27−instance ToParamSchema Unit
28−instance ToSchema Unit
29−
30−unitSchemaJSON :: Value
31−unitSchemaJSON = [aesonQQ|
32−{
33− "type": "string",
34− "enum": ["Unit"]
35−}
36−|]
37−
38−-- ========================================================================
39−-- Color (enum)
40−-- ========================================================================
41−data Color
42− = Red
43− | Green
44− | Blue
45− deriving (Generic)
46−instance ToParamSchema Color
47−instance ToSchema Color
48−
49−colorSchemaJSON :: Value
50−colorSchemaJSON = [aesonQQ|
51−{
52− "type": "string",
53− "enum": ["Red", "Green", "Blue"]
54−}
55−|]
56−
57−-- ========================================================================
58−-- Shade (paramSchemaToNamedSchema)
59−-- ========================================================================
60−
61−data Shade = Dim | Bright deriving (Generic)
62−instance ToParamSchema Shade
63−
64−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
65−
66−shadeSchemaJSON :: Value
67−shadeSchemaJSON = [aesonQQ|
68−{
69− "type": "string",
70− "enum": ["Dim", "Bright"]
71−}
72−|]
73−
74−-- ========================================================================
75−-- Paint (record with bounded enum property)
76−-- ========================================================================
77−
78−newtype Paint = Paint { color :: Color }
79− deriving (Generic)
80−instance ToSchema Paint
81−
82−paintSchemaJSON :: Value
83−paintSchemaJSON = [aesonQQ|
84−{
85− "type": "object",
86− "properties":
87− {
88− "color":
89− {
90− "$ref": "#/definitions/Color"
91− }
92− },
93− "required": ["color"]
94−}
95−|]
96−
97−paintInlinedSchemaJSON :: Value
98−paintInlinedSchemaJSON = [aesonQQ|
99−{
100− "type": "object",
101− "properties":
102− {
103− "color":
104− {
105− "type": "string",
106− "enum": ["Red", "Green", "Blue"]
107− }
108− },
109− "required": ["color"]
110−}
111−|]
112−
113−-- ========================================================================
114−-- Status (constructorTagModifier)
115−-- ========================================================================
116−
117−data Status
118− = StatusOk
119− | StatusError
120− deriving (Generic)
121−
122−instance ToParamSchema Status where
123− toParamSchema = genericToParamSchema defaultSchemaOptions
124− { constructorTagModifier = map toLower . drop (length "Status") }
125−instance ToSchema Status where
126− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
127− { constructorTagModifier = map toLower . drop (length "Status") }
128−
129−statusSchemaJSON :: Value
130−statusSchemaJSON = [aesonQQ|
131−{
132− "type": "string",
133− "enum": ["ok", "error"]
134−}
135−|]
136−
137−-- ========================================================================
138−-- Email (newtype with unwrapUnaryRecords set to True)
139−-- ========================================================================
140−
141−newtype Email = Email { getEmail :: String }
142− deriving (Generic)
143−instance ToParamSchema Email
144−instance ToSchema Email where
145− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
146− { unwrapUnaryRecords = True }
147−
148−emailSchemaJSON :: Value
149−emailSchemaJSON = [aesonQQ|
150−{
151− "type": "string"
152−}
153−|]
154−
155−-- ========================================================================
156−-- UserId (non-record newtype)
157−-- ========================================================================
158−
159−newtype UserId = UserId Integer
160− deriving (Eq, Ord, Generic)
161−instance ToParamSchema UserId
162−instance ToSchema UserId
163−
164−userIdSchemaJSON :: Value
165−userIdSchemaJSON = [aesonQQ|
166−{
167− "type": "integer"
168−}
169−|]
170−
171−-- ========================================================================
172−-- UserGroup (set newtype)
173−-- ========================================================================
174−
175−newtype UserGroup = UserGroup (Set UserId)
176− deriving (Generic)
177−instance ToSchema UserGroup
178−
179−userGroupSchemaJSON :: Value
180−userGroupSchemaJSON = [aesonQQ|
181−{
182− "type": "array",
183− "items": { "$ref": "#/definitions/UserId" },
184− "uniqueItems": true
185−}
186−|]
187−
188−-- ========================================================================
189−-- Person (simple record with optional fields)
190−-- ========================================================================
191−data Person = Person
192− { name :: String
193− , phone :: Integer
194− , email :: Maybe String
195− } deriving (Generic)
196−
197−instance ToSchema Person
198−
199−personSchemaJSON :: Value
200−personSchemaJSON = [aesonQQ|
201−{
202− "type": "object",
203− "properties":
204− {
205− "name": { "type": "string" },
206− "phone": { "type": "integer" },
207− "email": { "type": "string" }
208− },
209− "required": ["name", "phone"]
210−}
211−|]
212−
213−-- ========================================================================
214−-- Player (record newtype)
215−-- ========================================================================
216−
217−newtype Player = Player
218− { position :: Point
219− } deriving (Generic)
220−instance ToSchema Player
221−
222−playerSchemaJSON :: Value
223−playerSchemaJSON = [aesonQQ|
224−{
225− "type": "object",
226− "properties":
227− {
228− "position":
229− {
230− "$ref": "#/definitions/Point"
231− }
232− },
233− "required": ["position"]
234−}
235−|]
236−
237−newtype Players = Players [Inlined Player]
238− deriving (Generic)
239−instance ToSchema Players
240−
241−playersSchemaJSON :: Value
242−playersSchemaJSON = [aesonQQ|
243−{
244− "type": "array",
245− "items":
246− {
247− "type": "object",
248− "properties":
249− {
250− "position":
251− {
252− "$ref": "#/definitions/Point"
253− }
254− },
255− "required": ["position"]
256− }
257−}
258−|]
259−
260−-- ========================================================================
261−-- Character (sum type with ref and record in alternative)
262−-- ========================================================================
263−
264−data Character
265− = PC Player
266− | NPC { npcName :: String, npcPosition :: Point }
267− deriving (Generic)
268−instance ToSchema Character
269−
270−characterSchemaJSON :: Value
271−characterSchemaJSON = [aesonQQ|
272−{
273− "type": "object",
274− "properties":
275− {
276− "PC": { "$ref": "#/definitions/Player" },
277− "NPC":
278− {
279− "type": "object",
280− "properties":
281− {
282− "npcName": { "type": "string" },
283− "npcPosition": { "$ref": "#/definitions/Point" }
284− },
285− "required": ["npcName", "npcPosition"]
286− }
287− },
288− "maxProperties": 1,
289− "minProperties": 1
290−}
291−|]
292−
293−characterInlinedSchemaJSON :: Value
294−characterInlinedSchemaJSON = [aesonQQ|
295−{
296− "type": "object",
297− "properties":
298− {
299− "PC":
300− {
301− "type": "object",
302− "properties":
303− {
304− "position":
305− {
306− "type": "object",
307− "properties":
308− {
309− "x": { "type": "number", "format": "double" },
310− "y": { "type": "number", "format": "double" }
311− },
312− "required": ["x", "y"]
313− }
314− },
315− "required": ["position"]
316− },
317− "NPC":
318− {
319− "type": "object",
320− "properties":
321− {
322− "npcName": { "type": "string" },
323− "npcPosition":
324− {
325− "type": "object",
326− "properties":
327− {
328− "x": { "type": "number", "format": "double" },
329− "y": { "type": "number", "format": "double" }
330− },
331− "required": ["x", "y"]
332− }
333− },
334− "required": ["npcName", "npcPosition"]
335− }
336− },
337− "maxProperties": 1,
338− "minProperties": 1
339−}
340−|]
341−
342−characterInlinedPlayerSchemaJSON :: Value
343−characterInlinedPlayerSchemaJSON = [aesonQQ|
344−{
345− "type": "object",
346− "properties":
347− {
348− "PC":
349− {
350− "type": "object",
351− "properties":
352− {
353− "position":
354− {
355− "$ref": "#/definitions/Point"
356− }
357− },
358− "required": ["position"]
359− },
360− "NPC":
361− {
362− "type": "object",
363− "properties":
364− {
365− "npcName": { "type": "string" },
366− "npcPosition": { "$ref": "#/definitions/Point" }
367− },
368− "required": ["npcName", "npcPosition"]
369− }
370− },
371− "maxProperties": 1,
372− "minProperties": 1
373−}
374−|]
375−
376−-- ========================================================================
377−-- ISPair (non-record product data type)
378−-- ========================================================================
379−data ISPair = ISPair Integer String
380− deriving (Generic)
381−
382−instance ToSchema ISPair
383−
384−ispairSchemaJSON :: Value
385−ispairSchemaJSON = [aesonQQ|
386−{
387− "type": "array",
388− "items":
389− [
390− { "type": "integer" },
391− { "type": "string" }
392− ],
393− "minItems": 2,
394− "maxItems": 2
395−}
396−|]
397−
398−-- ========================================================================
399−-- Point (record data type with custom fieldLabelModifier)
400−-- ========================================================================
401−
402−data Point = Point
403− { pointX :: Double
404− , pointY :: Double
405− } deriving (Generic)
406−
407−instance ToSchema Point where
408− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
409− { fieldLabelModifier = map toLower . drop (length "point") }
410−
411−pointSchemaJSON :: Value
412−pointSchemaJSON = [aesonQQ|
413−{
414− "type": "object",
415− "properties":
416− {
417− "x": { "type": "number", "format": "double" },
418− "y": { "type": "number", "format": "double" }
419− },
420− "required": ["x", "y"]
421−}
422−|]
423−
424−-- ========================================================================
425−-- Point (record data type with multiple fields)
426−-- ========================================================================
427−
428−data Point5 = Point5
429− { point5X :: Double
430− , point5Y :: Double
431− , point5Z :: Double
432− , point5U :: Double
433− , point5V :: Double -- 5 dimensional!
434− } deriving (Generic)
435−
436−instance ToSchema Point5 where
437− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
438− { fieldLabelModifier = map toLower . drop (length "point5") }
439−
440−point5SchemaJSON :: Value
441−point5SchemaJSON = [aesonQQ|
442−{
443− "type": "object",
444− "properties":
445− {
446− "x": { "type": "number", "format": "double" },
447− "y": { "type": "number", "format": "double" },
448− "z": { "type": "number", "format": "double" },
449− "u": { "type": "number", "format": "double" },
450− "v": { "type": "number", "format": "double" }
451− },
452− "required": ["x", "y", "z", "u", "v"]
453−}
454−|]
455−
456−point5Properties :: [String]
457−point5Properties = ["x", "y", "z", "u", "v"]
458−
459−-- ========================================================================
460−-- MyRoseTree (custom datatypeNameModifier)
461−-- ========================================================================
462−
463−data MyRoseTree = MyRoseTree
464− { root :: String
465− , trees :: [MyRoseTree]
466− } deriving (Generic)
467−
468−instance ToSchema MyRoseTree where
469− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
470− { datatypeNameModifier = drop (length "My") }
471−
472−myRoseTreeSchemaJSON :: Value
473−myRoseTreeSchemaJSON = [aesonQQ|
474−{
475− "type": "object",
476− "properties":
477− {
478− "root": { "type": "string" },
479− "trees":
480− {
481− "type": "array",
482− "items":
483− {
484− "$ref": "#/definitions/RoseTree"
485− }
486− }
487− },
488− "required": ["root", "trees"]
489−}
490−|]
491−
492−data MyRoseTree' = MyRoseTree'
493− { root' :: String
494− , trees' :: [MyRoseTree']
495− } deriving (Generic)
496−
497−instance ToSchema MyRoseTree' where
498− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
499− { datatypeNameModifier = map toLower }
500−
501−myRoseTreeSchemaJSON' :: Value
502−myRoseTreeSchemaJSON' = [aesonQQ|
503−{
504− "type": "object",
505− "properties":
506− {
507− "root'": { "type": "string" },
508− "trees'":
509− {
510− "type": "array",
511− "items":
512− {
513− "$ref": "#/definitions/myrosetree'"
514− }
515− }
516− },
517− "required": ["root'", "trees'"]
518−}
519−|]
520−
521−-- ========================================================================
522−-- Inlined (newtype for inlining schemas)
523−-- ========================================================================
524−
525−newtype Inlined a = Inlined { getInlined :: a }
526−
527−instance ToSchema a => ToSchema (Inlined a) where
528− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
529− where
530− unname (NamedSchema _ s) = NamedSchema Nothing s
531−
532−-- ========================================================================
533−-- Light (sum type with unwrapUnaryRecords)
534−-- ========================================================================
535−
536−data Light
537− = NoLight
538− | LightFreq Double
539− | LightColor Color
540− | LightWaveLength { waveLength :: Double }
541− deriving (Generic)
542−
543−instance ToSchema Light where
544− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
545− { unwrapUnaryRecords = True }
546−
547−lightSchemaJSON :: Value
548−lightSchemaJSON = [aesonQQ|
549−{
550− "type": "object",
551− "properties":
552− {
553− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
554− "LightFreq": { "type": "number", "format": "double" },
555− "LightColor": { "$ref": "#/definitions/Color" },
556− "LightWaveLength": { "type": "number", "format": "double" }
557− },
558− "maxProperties": 1,
559− "minProperties": 1
560−}
561−|]
562−
563−lightInlinedSchemaJSON :: Value
564−lightInlinedSchemaJSON = [aesonQQ|
565−{
566− "type": "object",
567− "properties":
568− {
569− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },
570− "LightFreq": { "type": "number", "format": "double" },
571− "LightColor":
572− {
573− "type": "string",
574− "enum": ["Red", "Green", "Blue"]
575− },
576− "LightWaveLength": { "type": "number", "format": "double" }
577− },
578− "maxProperties": 1,
579− "minProperties": 1
580−}
581−|]
582−
583−-- ========================================================================
584−-- ResourceId (series of newtypes)
585−-- ========================================================================
586−
587−newtype Id = Id String deriving (Generic)
588−instance ToSchema Id
589−
590−newtype ResourceId = ResourceId Id deriving (Generic)
591−instance ToSchema ResourceId
592−
593−-- ========================================================================
594−-- ButtonImages (bounded enum key mapping)
595−-- ========================================================================
596−
597−data ButtonState = Neutral | Focus | Active | Hover | Disabled
598− deriving (Show, Bounded, Enum, Generic)
599−
600−instance ToJSON ButtonState
601−instance ToSchema ButtonState
602−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
603−
604−type ImageUrl = Text.Text
605−
606−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
607− deriving (Generic)
608−
609−instance ToJSON ButtonImages where
610− toJSON = toJSON . getButtonImages
611−
612−instance ToSchema ButtonImages where
613− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
614− declareSchemaBoundedEnumKeyMapping
615−
616−buttonImagesSchemaJSON :: Value
617−buttonImagesSchemaJSON = [aesonQQ|
618−{
619− "type": "object",
620− "properties":
621− {
622− "Neutral": { "type": "string" },
623− "Focus": { "type": "string" },
624− "Active": { "type": "string" },
625− "Hover": { "type": "string" },
626− "Disabled": { "type": "string" }
627− }
628−}
629−|]
630−
631−-- ========================================================================
632−-- SingleMaybeField (single field data with optional field)
633−-- ========================================================================
634−
635−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }
636− deriving (Show, Generic)
637−
638−instance ToJSON SingleMaybeField
639−instance ToSchema SingleMaybeField
640−
641−singleMaybeFieldSchemaJSON :: Value
642−singleMaybeFieldSchemaJSON = [aesonQQ|
643−{
644− "type": "object",
645− "properties":
646− {
647− "singleMaybeField": { "type": "string" }
648− }
649−}
650−|]
651−
652−
653−-- ========================================================================
654−-- TimeOfDay
655−-- ========================================================================
656−data TimeOfDay
657− = Int
658− | Pico
659− deriving (Generic)
660−instance ToSchema TimeOfDay
661−instance ToParamSchema TimeOfDay
662−
663−
664−timeOfDaySchemaJSON :: Value
665−timeOfDaySchemaJSON = [aesonQQ|
666−{
667− "example": "12:33:15",
668− "type": "string",
669− "format": "hh:MM:ss"
670−}
671−|]
672−
673−timeOfDayParamSchemaJSON :: Value
674−timeOfDayParamSchemaJSON = [aesonQQ|
675−{
676− "type": "string",
677− "format": "hh:MM:ss"
678−}
679−|]
test/Data/Swagger/ParamSchemaSpec.hs+84−8
@@ -3,11 +3,10 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
76module Data.Swagger.ParamSchemaSpec where
87
9−import Data.Aeson
10−import Data.Aeson.QQ.Simple
8+import Data.Aeson (Value)
9+import Data.Aeson.QQ
1110import Data.Char
1211import Data.Proxy
1312import GHC.Generics
@@ -15,12 +14,8 @@ import GHC.Generics
1514import Data.Swagger
1615import Data.Swagger.Internal (SwaggerKind(..))
1716
18−import Data.Swagger.CommonTestTypes
1917import SpecCommon
2018import Test.Hspec
21−import Data.Time.LocalTime
22−
23−import qualified Data.HashMap.Strict as HM
2419
2520checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
2621checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
@@ -34,7 +29,88 @@ spec = do
3429 context "Unary records" $ do
3530 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
3631 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
3832
3933main :: IO ()
4034main = 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.hsdeleted−168
@@ -1,168 +0,0 @@
1−{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE PackageImports #-}
4−module Data.Swagger.Schema.GeneratorSpec where
5−
6−import Prelude ()
7−import Prelude.Compat
8−
9−import Data.Swagger
10−import Data.Swagger.Schema.Generator
11−
12−import Control.Lens.Operators
13−import Data.Aeson
14−import Data.Hashable (Hashable)
15−import Data.HashMap.Strict (HashMap)
16−import qualified Data.HashMap.Strict as HashMap
17−import "unordered-containers" Data.HashSet (HashSet)
18−import qualified "unordered-containers" Data.HashSet as HashSet
19−import Data.Int
20−import Data.IntMap (IntMap)
21−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
22−import Data.Map (Map, fromList)
23−import Data.Monoid (mempty)
24−import Data.Proxy
25−import Data.Proxy
26−import Data.Set (Set)
27−import qualified Data.Text as T
28−import qualified Data.Text.Lazy as TL
29−import Data.Time
30−import Data.Version (Version)
31−import Data.Word
32−import GHC.Generics
33−
34−import Test.Hspec
35−import Test.Hspec.QuickCheck
36−import Test.QuickCheck
37−
38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
39−shouldValidate = validateFromJSON
40−
41−
42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
43−shouldNotValidate = expectFailure . shouldValidate
44−
45−
46−spec :: Spec
47−spec = do
48− describe "FromJSON validation" $ do
49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)
51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)
52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)
53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)
54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)
60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
64− prop "String" $ shouldValidate (Proxy :: Proxy String)
65− prop "()" $ shouldValidate (Proxy :: Proxy ())
66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
71− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
74− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
82− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
83− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
84− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
85− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
86− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
87− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
88− describe "Invalid FromJSON validation" $ do
89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)
93−
94−-- =============================
95−-- Data types and bunk instances
96−-- =============================
97−
98−data WrongType = WrongType Bool
99−
100−instance FromJSON WrongType where
101− parseJSON = withBool "WrongType" $ return . WrongType
102−
103−instance ToSchema WrongType where
104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $
105− mempty
106− & type_ ?~ SwaggerObject
107−
108−
109−data MissingRequired = MissingRequired
110− { propA :: String
111− , propB :: Bool
112− }
113−
114−instance FromJSON MissingRequired where
115− parseJSON = withObject "MissingRequired" $ \o ->
116− MissingRequired
117− <$> o .: "propA"
118− <*> o .: "propB"
119−
120−instance ToSchema MissingRequired where
121− declareNamedSchema _ = do
122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
124− return . NamedSchema (Just "MissingRequired") $
125− mempty
126− & type_ ?~ SwaggerObject
127− & properties .~ [("propA", stringSchema)
128− ,("propB", boolSchema)
129− ]
130− & required .~ ["propA"]
131−
132−data MissingProperty = MissingProperty
133− { propC :: String
134− , propD :: Bool
135− }
136−
137−instance FromJSON MissingProperty where
138− parseJSON = withObject "MissingProperty" $ \o ->
139− MissingProperty
140− <$> o .: "propC"
141− <*> o .: "propD"
142−
143−instance ToSchema MissingProperty where
144− declareNamedSchema _ = do
145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)
146− return . NamedSchema (Just "MissingProperty") $
147− mempty
148− & type_ ?~ SwaggerObject
149− & properties .~ [("propC", stringSchema)]
150− & required .~ ["propC"]
151−
152−data WrongPropType = WrongPropType
153− { propE :: String
154− }
155−
156−instance FromJSON WrongPropType where
157− parseJSON = withObject "WrongPropType" $ \o ->
158− WrongPropType
159− <$> o .: "propE"
160−
161−instance ToSchema WrongPropType where
162− declareNamedSchema _ = do
163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
164− return . NamedSchema (Just "WrongPropType") $
165− mempty
166− & type_ ?~ SwaggerObject
167− & properties .~ [("propE", boolSchema)]
168− & required .~ ["propE"]
test/Data/Swagger/Schema/ValidationSpec.hs+55−71
@@ -1,41 +1,37 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE PackageImports #-}
4+{-# LANGUAGE RecordWildCards #-}
55{-# LANGUAGE ScopedTypeVariables #-}
66{-# OPTIONS_GHC -fno-warn-orphans #-}
77module Data.Swagger.Schema.ValidationSpec where
88
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)
9+import Control.Applicative
10+import Data.Aeson
11+import Data.Aeson.Types
12+import Data.Int
13+import Data.IntMap (IntMap)
14+import Data.Hashable (Hashable)
15+import "unordered-containers" Data.HashSet (HashSet)
1716import qualified "unordered-containers" Data.HashSet as HashSet
18−import Data.Int
19−import Data.IntMap (IntMap)
20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
21−import Data.Map (Map, fromList)
22−import Data.Monoid (mempty)
23−import Data.Proxy
24−import Data.Set (Set)
25−import qualified Data.Text as T
26−import qualified Data.Text.Lazy as TL
27−import Data.Time
28−import Data.Version (Version)
29−import Data.Word
30−import GHC.Generics
31−
32−import Data.Swagger
33−import Data.Swagger.Declare
34−
35−import Test.Hspec
36−import Test.Hspec.QuickCheck
37−import Test.QuickCheck
38−import Test.QuickCheck.Instances ()
17+import Data.HashMap.Strict (HashMap)
18+import qualified Data.HashMap.Strict as HashMap
19+import Data.Map (Map)
20+import Data.Monoid (mempty)
21+import Data.Proxy
22+import Data.Time
23+import qualified Data.Text as T
24+import qualified Data.Text.Lazy as TL
25+import Data.Set (Set)
26+import Data.Word
27+import GHC.Generics
28+
29+import Data.Swagger
30+import Data.Swagger.Declare
31+
32+import Test.Hspec
33+import Test.Hspec.QuickCheck
34+import Test.QuickCheck
3935
4036shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
4137shouldValidate _ x = validateToJSON x == []
@@ -73,7 +69,6 @@ spec = do
7369 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
7470 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
7571 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
7772 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
7873 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
7974 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
@@ -83,7 +78,6 @@ spec = do
8378 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
8479 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
8580 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
8781 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
8882 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
8983 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
@@ -93,8 +87,6 @@ spec = do
9387 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
9488 prop "Light" $ shouldValidate (Proxy :: Proxy Light)
9589 prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
96− prop "Version" $ shouldValidate (Proxy :: Proxy Version)
97− prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
9890
9991 describe "invalid cases" $ do
10092 prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON
@@ -140,9 +132,9 @@ instance Arbitrary Color where
140132 arbitrary = arbitraryBoundedEnum
141133
142134invalidColorToJSON :: Color -> Value
143−invalidColorToJSON Red = toJSON "red"
144−invalidColorToJSON Green = toJSON "green"
145−invalidColorToJSON Blue = toJSON "blue"
135+invalidColorToJSON Red = toJSON "red"
136+invalidColorToJSON Green = toJSON "green"
137+invalidColorToJSON Blue = toJSON "blue"
146138
147139-- ========================================================================
148140-- Paint (record with bounded enum property)
@@ -236,43 +228,35 @@ invalidButtonImagesToJSON = genericToJSON defaultOptions
236228instance Arbitrary ButtonImages where
237229 arbitrary = ButtonImages <$> arbitrary
238230
239−-- ========================================================================
240−-- FreeForm (wraps a raw JSON Value)
241−-- ========================================================================
231+-- Arbitrary instances for common types
242232
243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
244− deriving (Show, Generic)
233+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
234+ arbitrary = HashMap.fromList <$> arbitrary
245235
246−instance ToJSON FreeForm where
247− toJSON = toJSON . jsonContent
236+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where
237+ arbitrary = HashSet.fromList <$> arbitrary
248238
249−instance ToSchema FreeForm where
250− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
251− & type_ ?~ SwaggerObject
252− & additionalProperties ?~ AdditionalPropertiesAllowed True
239+instance Arbitrary T.Text where
240+ arbitrary = T.pack <$> arbitrary
253241
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)
242+instance Arbitrary TL.Text where
243+ arbitrary = TL.pack <$> arbitrary
244+
245+instance Arbitrary Day where
246+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary
247+
248+instance Arbitrary LocalTime where
249+ arbitrary = LocalTime
250+ <$> arbitrary
251+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))
261252
262253instance Eq ZonedTime where
263254 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
264255
265−-- ========================================================================
266−-- Arbitrary instance for Data.Aeson.Value
267−-- ========================================================================
256+instance Arbitrary ZonedTime where
257+ arbitrary = ZonedTime
258+ <$> arbitrary
259+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))
268260
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) ]
261+instance Arbitrary UTCTime where
262+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
test/Data/Swagger/SchemaSpec.hs+588−10
@@ -8,22 +8,23 @@ import Prelude ()
88import Prelude.Compat
99
1010import Control.Lens ((^.))
11−import Data.Aeson (Value)
11+import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))
12+import Data.Aeson.Types (toJSONKeyText)
13+import Data.Aeson.QQ
14+import Data.Char
1215import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
1316import Data.Proxy
1417import Data.Set (Set)
18+import Data.Map (Map)
1519import qualified Data.Text as Text
20+import GHC.Generics
1621
1722import Data.Swagger
1823import Data.Swagger.Declare
1924
20−import Data.Swagger.CommonTestTypes
2125import SpecCommon
2226import Test.Hspec
2327
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
2728checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
2829checkToSchema proxy js = toSchema proxy <=> js
2930
@@ -77,10 +78,8 @@ spec = do
7778 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
7879 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
7980 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
8181 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
8282 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
8483 context "Sum types" $ do
8584 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
8685 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -96,7 +95,6 @@ spec = do
9695 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
9796 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
9897 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
10098 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
10199 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
102100 describe "Inlining Schemas" $ do
@@ -105,10 +103,590 @@ spec = do
105103 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
106104 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
107105 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
108− context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
109106 describe "Bounded Enum key mapping" $ do
110107 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
111− context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON
112108
113109main :: IO ()
114110main = hspec spec
111+
112+-- ========================================================================
113+-- Person (simple record with optional fields)
114+-- ========================================================================
115+data Person = Person
116+ { name :: String
117+ , phone :: Integer
118+ , email :: Maybe String
119+ } deriving (Generic)
120+
121+instance ToSchema Person
122+
123+personSchemaJSON :: Value
124+personSchemaJSON = [aesonQQ|
125+{
126+ "type": "object",
127+ "properties":
128+ {
129+ "name": { "type": "string" },
130+ "phone": { "type": "integer" },
131+ "email": { "type": "string" }
132+ },
133+ "required": ["name", "phone"]
134+}
135+|]
136+
137+-- ========================================================================
138+-- ISPair (non-record product data type)
139+-- ========================================================================
140+data ISPair = ISPair Integer String
141+ deriving (Generic)
142+
143+instance ToSchema ISPair
144+
145+ispairSchemaJSON :: Value
146+ispairSchemaJSON = [aesonQQ|
147+{
148+ "type": "array",
149+ "items":
150+ [
151+ { "type": "integer" },
152+ { "type": "string" }
153+ ],
154+ "minItems": 2,
155+ "maxItems": 2
156+}
157+|]
158+
159+-- ========================================================================
160+-- Point (record data type with custom fieldLabelModifier)
161+-- ========================================================================
162+
163+data Point = Point
164+ { pointX :: Double
165+ , pointY :: Double
166+ } deriving (Generic)
167+
168+instance ToSchema Point where
169+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
170+ { fieldLabelModifier = map toLower . drop (length "point") }
171+
172+pointSchemaJSON :: Value
173+pointSchemaJSON = [aesonQQ|
174+{
175+ "type": "object",
176+ "properties":
177+ {
178+ "x": { "type": "number", "format": "double" },
179+ "y": { "type": "number", "format": "double" }
180+ },
181+ "required": ["x", "y"]
182+}
183+|]
184+
185+-- ========================================================================
186+-- Point (record data type with multiple fields)
187+-- ========================================================================
188+
189+data Point5 = Point5
190+ { point5X :: Double
191+ , point5Y :: Double
192+ , point5Z :: Double
193+ , point5U :: Double
194+ , point5V :: Double -- 5 dimensional!
195+ } deriving (Generic)
196+
197+instance ToSchema Point5 where
198+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
199+ { fieldLabelModifier = map toLower . drop (length "point5") }
200+
201+point5SchemaJSON :: Value
202+point5SchemaJSON = [aesonQQ|
203+{
204+ "type": "object",
205+ "properties":
206+ {
207+ "x": { "type": "number", "format": "double" },
208+ "y": { "type": "number", "format": "double" },
209+ "z": { "type": "number", "format": "double" },
210+ "u": { "type": "number", "format": "double" },
211+ "v": { "type": "number", "format": "double" }
212+ },
213+ "required": ["x", "y", "z", "u", "v"]
214+}
215+|]
216+
217+point5Properties :: [String]
218+point5Properties = ["x", "y", "z", "u", "v"]
219+
220+-- ========================================================================
221+-- Color (enum)
222+-- ========================================================================
223+data Color
224+ = Red
225+ | Green
226+ | Blue
227+ deriving (Generic)
228+instance ToSchema Color
229+
230+colorSchemaJSON :: Value
231+colorSchemaJSON = [aesonQQ|
232+{
233+ "type": "string",
234+ "enum": ["Red", "Green", "Blue"]
235+}
236+|]
237+
238+-- ========================================================================
239+-- Shade (paramSchemaToNamedSchema)
240+-- ========================================================================
241+
242+data Shade = Dim | Bright deriving (Generic)
243+instance ToParamSchema Shade
244+
245+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
246+
247+shadeSchemaJSON :: Value
248+shadeSchemaJSON = [aesonQQ|
249+{
250+ "type": "string",
251+ "enum": ["Dim", "Bright"]
252+}
253+|]
254+
255+-- ========================================================================
256+-- Paint (record with bounded enum property)
257+-- ========================================================================
258+
259+newtype Paint = Paint { color :: Color }
260+ deriving (Generic)
261+instance ToSchema Paint
262+
263+paintSchemaJSON :: Value
264+paintSchemaJSON = [aesonQQ|
265+{
266+ "type": "object",
267+ "properties":
268+ {
269+ "color":
270+ {
271+ "$ref": "#/definitions/Color"
272+ }
273+ },
274+ "required": ["color"]
275+}
276+|]
277+
278+paintInlinedSchemaJSON :: Value
279+paintInlinedSchemaJSON = [aesonQQ|
280+{
281+ "type": "object",
282+ "properties":
283+ {
284+ "color":
285+ {
286+ "type": "string",
287+ "enum": ["Red", "Green", "Blue"]
288+ }
289+ },
290+ "required": ["color"]
291+}
292+|]
293+
294+-- ========================================================================
295+-- Email (newtype with unwrapUnaryRecords set to True)
296+-- ========================================================================
297+
298+newtype Email = Email { getEmail :: String }
299+ deriving (Generic)
300+
301+instance ToSchema Email where
302+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
303+ { unwrapUnaryRecords = True }
304+
305+emailSchemaJSON :: Value
306+emailSchemaJSON = [aesonQQ|
307+{
308+ "type": "string"
309+}
310+|]
311+
312+-- ========================================================================
313+-- UserId (non-record newtype)
314+-- ========================================================================
315+
316+newtype UserId = UserId Integer
317+ deriving (Eq, Ord, Generic)
318+instance ToSchema UserId
319+
320+userIdSchemaJSON :: Value
321+userIdSchemaJSON = [aesonQQ|
322+{
323+ "type": "integer"
324+}
325+|]
326+
327+-- ========================================================================
328+-- UserGroup (set newtype)
329+-- ========================================================================
330+
331+newtype UserGroup = UserGroup (Set UserId)
332+ deriving (Generic)
333+instance ToSchema UserGroup
334+
335+userGroupSchemaJSON :: Value
336+userGroupSchemaJSON = [aesonQQ|
337+{
338+ "type": "array",
339+ "items": { "$ref": "#/definitions/UserId" },
340+ "uniqueItems": true
341+}
342+|]
343+
344+-- ========================================================================
345+-- Player (record newtype)
346+-- ========================================================================
347+
348+newtype Player = Player
349+ { position :: Point
350+ } deriving (Generic)
351+instance ToSchema Player
352+
353+playerSchemaJSON :: Value
354+playerSchemaJSON = [aesonQQ|
355+{
356+ "type": "object",
357+ "properties":
358+ {
359+ "position":
360+ {
361+ "$ref": "#/definitions/Point"
362+ }
363+ },
364+ "required": ["position"]
365+}
366+|]
367+
368+-- ========================================================================
369+-- MyRoseTree (custom datatypeNameModifier)
370+-- ========================================================================
371+
372+data MyRoseTree = MyRoseTree
373+ { root :: String
374+ , trees :: [MyRoseTree]
375+ } deriving (Generic)
376+
377+instance ToSchema MyRoseTree where
378+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
379+ { datatypeNameModifier = drop (length "My") }
380+
381+myRoseTreeSchemaJSON :: Value
382+myRoseTreeSchemaJSON = [aesonQQ|
383+{
384+ "type": "object",
385+ "properties":
386+ {
387+ "root": { "type": "string" },
388+ "trees":
389+ {
390+ "type": "array",
391+ "items":
392+ {
393+ "$ref": "#/definitions/RoseTree"
394+ }
395+ }
396+ },
397+ "required": ["root", "trees"]
398+}
399+|]
400+
401+-- ========================================================================
402+-- Inlined (newtype for inlining schemas)
403+-- ========================================================================
404+
405+newtype Inlined a = Inlined { getInlined :: a }
406+
407+instance ToSchema a => ToSchema (Inlined a) where
408+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
409+ where
410+ unname (NamedSchema _ s) = NamedSchema Nothing s
411+
412+newtype Players = Players [Inlined Player]
413+ deriving (Generic)
414+instance ToSchema Players
415+
416+playersSchemaJSON :: Value
417+playersSchemaJSON = [aesonQQ|
418+{
419+ "type": "array",
420+ "items":
421+ {
422+ "type": "object",
423+ "properties":
424+ {
425+ "position":
426+ {
427+ "$ref": "#/definitions/Point"
428+ }
429+ },
430+ "required": ["position"]
431+ }
432+}
433+|]
434+
435+-- ========================================================================
436+-- Status (sum type with unary constructors)
437+-- ========================================================================
438+
439+data Status
440+ = StatusOk String
441+ | StatusError String
442+ deriving (Generic)
443+
444+instance ToSchema Status where
445+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
446+ { constructorTagModifier = map toLower . drop (length "Status") }
447+
448+statusSchemaJSON :: Value
449+statusSchemaJSON = [aesonQQ|
450+{
451+ "type": "object",
452+ "properties":
453+ {
454+ "ok": { "type": "string" },
455+ "error": { "type": "string" }
456+ },
457+ "maxProperties": 1,
458+ "minProperties": 1
459+}
460+|]
461+
462+-- ========================================================================
463+-- Unit type
464+-- ========================================================================
465+
466+data Unit = Unit deriving (Generic)
467+instance ToSchema Unit
468+
469+unitSchemaJSON :: Value
470+unitSchemaJSON = [aesonQQ|
471+{
472+ "type": "string",
473+ "enum": ["Unit"]
474+}
475+|]
476+
477+
478+-- ========================================================================
479+-- Character (sum type with ref and record in alternative)
480+-- ========================================================================
481+
482+data Character
483+ = PC Player
484+ | NPC { npcName :: String, npcPosition :: Point }
485+ deriving (Generic)
486+instance ToSchema Character
487+
488+characterSchemaJSON :: Value
489+characterSchemaJSON = [aesonQQ|
490+{
491+ "type": "object",
492+ "properties":
493+ {
494+ "PC": { "$ref": "#/definitions/Player" },
495+ "NPC":
496+ {
497+ "type": "object",
498+ "properties":
499+ {
500+ "npcName": { "type": "string" },
501+ "npcPosition": { "$ref": "#/definitions/Point" }
502+ },
503+ "required": ["npcName", "npcPosition"]
504+ }
505+ },
506+ "maxProperties": 1,
507+ "minProperties": 1
508+}
509+|]
510+
511+characterInlinedSchemaJSON :: Value
512+characterInlinedSchemaJSON = [aesonQQ|
513+{
514+ "type": "object",
515+ "properties":
516+ {
517+ "PC":
518+ {
519+ "type": "object",
520+ "properties":
521+ {
522+ "position":
523+ {
524+ "type": "object",
525+ "properties":
526+ {
527+ "x": { "type": "number", "format": "double" },
528+ "y": { "type": "number", "format": "double" }
529+ },
530+ "required": ["x", "y"]
531+ }
532+ },
533+ "required": ["position"]
534+ },
535+ "NPC":
536+ {
537+ "type": "object",
538+ "properties":
539+ {
540+ "npcName": { "type": "string" },
541+ "npcPosition":
542+ {
543+ "type": "object",
544+ "properties":
545+ {
546+ "x": { "type": "number", "format": "double" },
547+ "y": { "type": "number", "format": "double" }
548+ },
549+ "required": ["x", "y"]
550+ }
551+ },
552+ "required": ["npcName", "npcPosition"]
553+ }
554+ },
555+ "maxProperties": 1,
556+ "minProperties": 1
557+}
558+|]
559+
560+characterInlinedPlayerSchemaJSON :: Value
561+characterInlinedPlayerSchemaJSON = [aesonQQ|
562+{
563+ "type": "object",
564+ "properties":
565+ {
566+ "PC":
567+ {
568+ "type": "object",
569+ "properties":
570+ {
571+ "position":
572+ {
573+ "$ref": "#/definitions/Point"
574+ }
575+ },
576+ "required": ["position"]
577+ },
578+ "NPC":
579+ {
580+ "type": "object",
581+ "properties":
582+ {
583+ "npcName": { "type": "string" },
584+ "npcPosition": { "$ref": "#/definitions/Point" }
585+ },
586+ "required": ["npcName", "npcPosition"]
587+ }
588+ },
589+ "maxProperties": 1,
590+ "minProperties": 1
591+}
592+|]
593+
594+-- ========================================================================
595+-- Light (sum type with unwrapUnaryRecords)
596+-- ========================================================================
597+
598+data Light
599+ = NoLight
600+ | LightFreq Double
601+ | LightColor Color
602+ | LightWaveLength { waveLength :: Double }
603+ deriving (Generic)
604+
605+instance ToSchema Light where
606+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
607+ { unwrapUnaryRecords = True }
608+
609+lightSchemaJSON :: Value
610+lightSchemaJSON = [aesonQQ|
611+{
612+ "type": "object",
613+ "properties":
614+ {
615+ "NoLight": { "type": "array", "items": [] },
616+ "LightFreq": { "type": "number", "format": "double" },
617+ "LightColor": { "$ref": "#/definitions/Color" },
618+ "LightWaveLength": { "type": "number", "format": "double" }
619+ },
620+ "maxProperties": 1,
621+ "minProperties": 1
622+}
623+|]
624+
625+lightInlinedSchemaJSON :: Value
626+lightInlinedSchemaJSON = [aesonQQ|
627+{
628+ "type": "object",
629+ "properties":
630+ {
631+ "NoLight": { "type": "array", "items": [] },
632+ "LightFreq": { "type": "number", "format": "double" },
633+ "LightColor":
634+ {
635+ "type": "string",
636+ "enum": ["Red", "Green", "Blue"]
637+ },
638+ "LightWaveLength": { "type": "number", "format": "double" }
639+ },
640+ "maxProperties": 1,
641+ "minProperties": 1
642+}
643+|]
644+
645+-- ========================================================================
646+-- ResourceId (series of newtypes)
647+-- ========================================================================
648+
649+newtype Id = Id String deriving (Generic)
650+instance ToSchema Id
651+
652+newtype ResourceId = ResourceId Id deriving (Generic)
653+instance ToSchema ResourceId
654+
655+-- ========================================================================
656+-- ButtonImages (bounded enum key mapping)
657+-- ========================================================================
658+
659+data ButtonState = Neutral | Focus | Active | Hover | Disabled
660+ deriving (Show, Bounded, Enum, Generic)
661+
662+instance ToJSON ButtonState
663+instance ToSchema ButtonState
664+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)
665+
666+type ImageUrl = Text.Text
667+
668+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
669+ deriving (Generic)
670+
671+instance ToJSON ButtonImages where
672+ toJSON = toJSON . getButtonImages
673+
674+instance ToSchema ButtonImages where
675+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
676+ declareSchemaBoundedEnumKeyMapping
677+
678+buttonImagesSchemaJSON :: Value
679+buttonImagesSchemaJSON = [aesonQQ|
680+{
681+ "type": "object",
682+ "properties":
683+ {
684+ "Neutral": { "type": "string" },
685+ "Focus": { "type": "string" },
686+ "Active": { "type": "string" },
687+ "Hover": { "type": "string" },
688+ "Disabled": { "type": "string" }
689+ }
690+}
691+|]
692+
test/Data/SwaggerSpec.hs+31−86
@@ -10,9 +10,9 @@ import Prelude.Compat
1010import Control.Lens
1111
1212import Data.Aeson
13−import Data.Aeson.QQ.Simple
13+import Data.Aeson.QQ
1414import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
15+import qualified Data.Set as Set
1616import Data.Text (Text)
1717
1818import Data.Swagger
@@ -37,13 +37,11 @@ spec = do
3737 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
3838 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
3939 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
4140 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
4241 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
4342 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
4443 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
4544 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
4745 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
4846 describe "Swagger Object" $ do
4947 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
@@ -128,7 +126,7 @@ licenseExampleJSON = [aesonQQ|
128126
129127operationExample :: Operation
130128operationExample = mempty
131− & tags .~ InsOrdHS.fromList ["pet"]
129+ & tags .~ Set.fromList ["pet"]
132130 & summary ?~ "Updates a pet in the store with form data"
133131 & description ?~ ""
134132 & operationId ?~ "updatePetWithForm"
@@ -159,7 +157,7 @@ operationExample = mempty
159157 stringSchema :: ParamLocation -> ParamOtherSchema
160158 stringSchema loc = mempty
161159 & in_ .~ loc
162− & type_ ?~ SwaggerString
160+ & type_ .~ SwaggerString
163161
164162operationExampleJSON :: Value
165163operationExampleJSON = [aesonQQ|
@@ -225,7 +223,7 @@ operationExampleJSON = [aesonQQ|
225223
226224schemaPrimitiveExample :: Schema
227225schemaPrimitiveExample = mempty
228− & type_ ?~ SwaggerString
226+ & type_ .~ SwaggerString
229227 & format ?~ "email"
230228
231229schemaPrimitiveExampleJSON :: Value
@@ -238,14 +236,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
238236
239237schemaSimpleModelExample :: Schema
240238schemaSimpleModelExample = mempty
241− & type_ ?~ SwaggerObject
239+ & type_ .~ SwaggerObject
242240 & required .~ [ "name" ]
243241 & properties .~
244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
242+ [ ("name", Inline (mempty & type_ .~ SwaggerString))
245243 , ("address", Ref (Reference "Address"))
246244 , ("age", Inline $ mempty
247245 & minimum_ ?~ 0
248− & type_ ?~ SwaggerInteger
246+ & type_ .~ SwaggerInteger
249247 & format ?~ "int32" ) ]
250248
251249schemaSimpleModelExampleJSON :: Value
@@ -273,8 +271,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
273271
274272schemaModelDictExample :: Schema
275273schemaModelDictExample = mempty
276− & type_ ?~ SwaggerObject
277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
274+ & type_ .~ SwaggerObject
275+ & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)
278276
279277schemaModelDictExampleJSON :: Value
280278schemaModelDictExampleJSON = [aesonQQ|
@@ -286,28 +284,15 @@ schemaModelDictExampleJSON = [aesonQQ|
286284}
287285|]
288286
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−
302287schemaWithExampleExample :: Schema
303288schemaWithExampleExample = mempty
304− & type_ ?~ SwaggerObject
289+ & type_ .~ SwaggerObject
305290 & properties .~
306291 [ ("id", Inline $ mempty
307− & type_ ?~ SwaggerInteger
292+ & type_ .~ SwaggerInteger
308293 & format ?~ "int64" )
309294 , ("name", Inline $ mempty
310− & type_ ?~ SwaggerString) ]
295+ & type_ .~ SwaggerString) ]
311296 & required .~ [ "name" ]
312297 & example ?~ [aesonQQ|
313298 {
@@ -346,19 +331,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
346331definitionsExample :: HashMap Text Schema
347332definitionsExample =
348333 [ ("Category", mempty
349− & type_ ?~ SwaggerObject
334+ & type_ .~ SwaggerObject
350335 & properties .~
351336 [ ("id", Inline $ mempty
352− & type_ ?~ SwaggerInteger
337+ & type_ .~ SwaggerInteger
353338 & format ?~ "int64")
354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
339+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
355340 , ("Tag", mempty
356− & type_ ?~ SwaggerObject
341+ & type_ .~ SwaggerObject
357342 & properties .~
358343 [ ("id", Inline $ mempty
359− & type_ ?~ SwaggerInteger
344+ & type_ .~ SwaggerInteger
360345 & format ?~ "int64")
361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
346+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
362347
363348definitionsExampleJSON :: Value
364349definitionsExampleJSON = [aesonQQ|
@@ -402,7 +387,7 @@ paramsDefinitionExample =
402387 & required ?~ True
403388 & schema .~ ParamOther (mempty
404389 & in_ .~ ParamQuery
405− & type_ ?~ SwaggerInteger
390+ & type_ .~ SwaggerInteger
406391 & format ?~ "int32" ))
407392 , ("limitParam", mempty
408393 & name .~ "limit"
@@ -410,7 +395,7 @@ paramsDefinitionExample =
410395 & required ?~ True
411396 & schema .~ ParamOther (mempty
412397 & in_ .~ ParamQuery
413− & type_ ?~ SwaggerInteger
398+ & type_ .~ SwaggerInteger
414399 & format ?~ "int32" )) ]
415400
416401paramsDefinitionExampleJSON :: Value
@@ -460,8 +445,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
460445-- Responses Definition object
461446-- =======================================================================
462447
463−securityDefinitionsExample :: SecurityDefinitions
464−securityDefinitionsExample = SecurityDefinitions
448+securityDefinitionsExample :: HashMap Text SecurityScheme
449+securityDefinitionsExample =
465450 [ ("api_key", SecurityScheme
466451 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
467452 , _securitySchemeDescription = Nothing })
@@ -493,46 +478,6 @@ securityDefinitionsExampleJSON = [aesonQQ|
493478}
494479|]
495480
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−
536481-- =======================================================================
537482-- Swagger object
538483-- =======================================================================
@@ -551,7 +496,7 @@ swaggerExample = mempty
551496 & at 200 ?~ Inline (mempty
552497 & description .~ "OK"
553498 & schema ?~ Inline (mempty
554− & type_ ?~ SwaggerObject
499+ & type_ .~ SwaggerObject
555500 & example ?~ [aesonQQ|
556501 {
557502 "created": 100,
@@ -560,9 +505,9 @@ swaggerExample = mempty
560505 & description ?~ "This is some real Todo right here"
561506 & properties .~
562507 [ ("created", Inline $ mempty
563− & type_ ?~ SwaggerInteger
508+ & type_ .~ SwaggerInteger
564509 & format ?~ "int32")
565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
510+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))
566511 & produces ?~ MimeList [ "application/json" ]
567512 & parameters .~
568513 [ Inline $ mempty
@@ -571,8 +516,8 @@ swaggerExample = mempty
571516 & description ?~ "TodoId param"
572517 & schema .~ ParamOther (mempty
573518 & in_ .~ ParamPath
574− & type_ ?~ SwaggerString ) ]
575− & tags .~ InsOrdHS.fromList [ "todo" ] ))
519+ & type_ .~ SwaggerString ) ]
520+ & tags .~ Set.fromList [ "todo" ] ))
576521
577522swaggerExampleJSON :: Value
578523swaggerExampleJSON = [aesonQQ|
@@ -1673,14 +1618,14 @@ petstoreExampleJSON = [aesonQQ|
16731618
16741619compositionSchemaExample :: Schema
16751620compositionSchemaExample = mempty
1676− & type_ ?~ SwaggerObject
1621+ & type_ .~ SwaggerObject
16771622 & Data.Swagger.allOf ?~ [
16781623 Ref (Reference "Other")
16791624 , Inline (mempty
1680− & type_ ?~ SwaggerObject
1625+ & type_ .~ SwaggerObject
16811626 & properties .~
16821627 [ ("greet", Inline $ mempty
1683− & type_ ?~ SwaggerString) ])
1628+ & type_ .~ SwaggerString) ])
16841629 ]
16851630
16861631compositionSchemaExampleJSON :: Value