git.iko.soy/typeable/swagger2
on 5297441 help sign in
5470313
swap
0 ahead, 167 behind
.ghci−1
since splitsnapshots
unifiedsplit
@@ -1,2 +1 @@
1:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/autogen/cabal_macros.h -optP-I -optPinclude
1:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/autogen/cabal_macros.h -optP-I -optPinclude
2−:set -hide-package base-compat-0.10.4
.travis.yml+81−140
@@ -1,162 +1,103 @@
1# This Travis job script has been generated by a script via
1# This Travis job script has been generated by a script via
2#
2#
3−# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal'
3+# make_travis_yml_2.hs '--branch' 'master' 'swagger2.cabal'
4#
4#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
5+# For more information, see https://github.com/hvr/multi-ghc-travis
6−#
7−# version: 0.5.20191020
8#
6#
9language: c
7language: c
10−dist: xenial
8+sudo: false
9+
11git:
10git:
12− # whether to recursively clone submodules
11+ submodules: false # whether to recursively clone submodules
13− submodules: false
12+
14branches:
13branches:
15 only:
14 only:
16 - master
15 - master
16+
17cache:
17cache:
18 directories:
18 directories:
19 - $HOME/.cabal/packages
19 - $HOME/.cabal/packages
20 - $HOME/.cabal/store
20 - $HOME/.cabal/store
21+
21before_cache:
22before_cache:
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
23+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
23 # remove files that are regenerated by 'cabal update'
24 # remove files that are regenerated by 'cabal update'
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
25+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
26+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
27+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
27− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
28+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
28− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
29+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
29− - rm -rfv $CABALHOME/packages/head.hackage
30+
30matrix:
31matrix:
31 include:
32 include:
32− - compiler: ghc-8.8.1
33+ - compiler: "ghc-7.8.4"
34+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
35+ env: HADDOCK=false
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
36+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}}
34− - compiler: ghc-8.6.5
37+ - compiler: "ghc-7.10.3"
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
38+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
36− - compiler: ghc-8.4.4
39+ env: HADDOCK=false
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
40+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}
38− - compiler: ghc-8.2.2
41+ - compiler: "ghc-8.0.2"
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
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]}}
40− - compiler: ghc-8.0.2
45+ - compiler: "ghc-8.2.1"
41− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
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+
42before_install:
49before_install:
43− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
50+ - HC=${CC}
44− - WITHCOMPILER="-w $HC"
45− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
46− - HCPKG="$HC-pkg"
47− - unset CC
51+ - unset CC
48− - CABAL=/opt/ghc/bin/cabal
52+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
49− - CABALHOME=$HOME/.cabal
53+ - PKGNAME='swagger2'
50− - export PATH="$CABALHOME/bin:$PATH"
54+
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
74install:
55install:
75− - ${CABAL} --version
56+ - cabal --version
76− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
57+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
77− - TEST=--enable-tests
78− - BENCH=--enable-benchmarks
58+ - BENCH=${BENCH---enable-benchmarks}
79− - HEADHACKAGE=false
59+ - TEST=${TEST---enable-tests}
80− - rm -f $CABALHOME/config
60+ - HADDOCK=${HADDOCK-true}
81− - |
61+ - INSTALLED=${INSTALLED-true}
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
62+ - travis_retry cabal update -v
111− # Generate cabal.project
63+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
112− - rm -rf cabal.project cabal.project.local cabal.project.freeze
64+ - rm -fv cabal.project.local
113− - touch cabal.project
65+ - "echo 'packages: .' > cabal.project"
114− - |
66+ - rm -f cabal.project.freeze
115− echo "packages: ." >> cabal.project
67+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all
116− - |
68+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all
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"
69+
118− - cat cabal.project || true
70+# Here starts the actual work to be performed for the package under test;
119− - cat cabal.project.local || true
71+# any command which exits with a non-zero exit code causes the build to fail.
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
126script:
72script:
127− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
73+ - if [ -f configure.ac ]; then autoreconf -i; fi
128− # Packaging...
74+ - rm -rf .ghc.environment.* dist/
129− - ${CABAL} v2-sdist all | color_cabal_output
75+ - cabal sdist # test that a source-distribution can be generated
130− # Unpacking...
76+ - cd dist/
131− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
77+ - SRCTAR=(${PKGNAME}-*.tar.gz)
132− - cd ${DISTDIR} || false
78+ - SRC_BASENAME="${SRCTAR/%.tar.gz}"
133− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
79+ - tar -xvf "./$SRC_BASENAME.tar.gz"
134− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
80+ - cd "$SRC_BASENAME/"
135− - PKGDIR_swagger2="$(find . -maxdepth 1 -type d -regex '.*/swagger2-[0-9.]*')"
81+## from here on, CWD is inside the extracted source-tarball
136− # Generate cabal.project
82+ - rm -fv cabal.project.local
83+ - "echo 'packages: .' > cabal.project"
84+ # this builds all libraries and executables (without tests/benchmarks)
137− - rm -rf cabal.project cabal.project.local cabal.project.freeze
85+ - rm -f cabal.project.freeze
138− - touch cabal.project
86+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
139− - |
87+ # this builds all libraries and executables (including tests/benchmarks)
140− echo "packages: ${PKGDIR_swagger2}" >> cabal.project
88+ # - rm -rf ./dist-newstyle
141− - |
89+
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"
90+ # Build with installed constraints for packages in global-db
143− - cat cabal.project || true
91+ - if $INSTALLED; then
144− - cat cabal.project.local || true
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;
145− # Building...
93+ else echo "Not building with installed constraints"; fi
146− # this builds all libraries and executables (without tests/benchmarks)
94+
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
95+ # build & run tests, build benchmarks
150− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
96+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
151− # Testing...
97+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi
152− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
98+
153− # cabal check...
154− - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)
155− # haddock...
99+ # haddock
156− - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi
100+ - rm -rf ./dist-newstyle
157− # Building without installed constraints for packages in global-db...
101+ - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";fi
158− - rm -f cabal.project.local
159− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
160
102
161−# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])
162# EOF
103# EOF
CHANGELOG.md+2−107
@@ -1,113 +1,8 @@
1−2.5
2−---
3−
4−Highlights:
5−- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));
6−- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));
7−- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));
8−
9−Fixes and minor changes:
10−- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));
11−- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));
12−- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));
13−
14−2.4
15−---
16−
17−- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5
18−- Tags aren't sorted
19− (see [#165](https://github.com/GetShopTV/swagger2/issues/165))
20−- Schema type is optional
21− (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))
22−- Take concrete 'Proxy' as argument
23− (see [#180](https://github.com/GetShopTV/swagger2/pull/180))
24−- GHC-8.8 preparations
25−
26−2.3.1.1
27−-------
28−
29−- Allow `network-3.0`
30−
31−2.3.1
32−-----
33−
34−- Add a quickcheck generator for aeson Values that match a swagger schema
35− (see [#162](https://github.com/GetShopTV/swagger2/pull/162))
36−- Add `ToParamSchema` instance for `SetCookie`
37− (see [#173](https://github.com/GetShopTV/swagger2/pull/173))
38−- Make nullary schemas valid
39− (see [#168](https://github.com/GetShopTV/swagger2/pull/168))
40−
41−2.3.0.1
42−-------
43−
44−- Support GHC-8.6
45−
46−2.3
47−---
48−
49−Major changes:
50−
51−- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));
52−- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));
53−
54−Dependencies and CI:
55−
56−- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));
57−- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));
58−- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));
59−- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));
60−
61−2.2.2
62−-----
63−
64−* Add `ToSchema Version` instance
65−* Use base-compat-batteries (0.10)
66−* PVP bounds
67−
68−2.2.1
69−-----
70−
71−* Add `Semigroup` instances
72−* GHC-8.4 compatibility
73−* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))
74−* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))
75−* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))
76−* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))
77−
78−2.2
79−---
80−
81−* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
82−* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));
83−* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):
84− * `genericNameSchema` — to give a custom schema `Generic`-based name;
85− * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;
86− * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;
87−* Add a few tests with invalid `Schema`.
88−
89−2.1.6
90−-----
91−
92−* Add `ToParamSchema` and `ToSchema` instances for `Fixed` (see [#121](https://github.com/GetShopTV/swagger2/pull/121)) and `Natural` (see [#123](https://github.com/GetShopTV/swagger2/pull/123));
93−* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));
94−* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).
95−
96−2.1.5
97−-----
98−
99−* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));
100−* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));
101−* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));
102−* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).
103−
1042.1.4.1
12.1.4.1
105-------
2-------
106
3
107−* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108));
4+* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95))
108−* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));
5+* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105))
109−* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));
110−* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).
111
6
1122.1.4
72.1.4
113-----
8-----
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2015-2017, GetShopTV
1+Copyright (c) 2015-2016, GetShopTV
2All rights reserved.
2All rights reserved.
3
3
4Redistribution and use in source and binary forms, with or without
4Redistribution and use in source and binary forms, with or without
README.md−2
@@ -1,7 +1,5 @@
1# swagger2
1# swagger2
2
2
3−[![Join the chat at https://gitter.im/haskell-swagger2/Lobby](https://badges.gitter.im/haskell-swagger2/Lobby.svg)](https://gitter.im/haskell-swagger2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
4−
5[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
3[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)
6[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
4[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)
7[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
5[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)
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
27 usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
27 usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
28 useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
28 useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
29 return $ NamedSchema (Just "UserSummary") $ mempty
29 return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ ?~ SwaggerObject
30+ & type_ .~ SwaggerObject
31 & properties .~
31 & properties .~
32 [ ("summaryUsername", usernameSchema )
32 [ ("summaryUsername", usernameSchema )
33 , ("summaryUserid" , useridSchema )
33 , ("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+8−48
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2-- |
1-- |
3-- Module: Data.Swagger
2-- Module: Data.Swagger
4-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -31,7 +30,6 @@ module Data.Swagger (
31
30
32 -- * Re-exports
31 -- * Re-exports
33 module Data.Swagger.Lens,
32 module Data.Swagger.Lens,
34− module Data.Swagger.Optics,
35 module Data.Swagger.Operation,
33 module Data.Swagger.Operation,
36 module Data.Swagger.ParamSchema,
34 module Data.Swagger.ParamSchema,
37 module Data.Swagger.Schema,
35 module Data.Swagger.Schema,
@@ -78,7 +76,6 @@ module Data.Swagger (
78 SwaggerItems(..),
76 SwaggerItems(..),
79 Xml(..),
77 Xml(..),
80 Pattern,
78 Pattern,
81− AdditionalProperties(..),
82
79
83 -- ** Responses
80 -- ** Responses
84 Responses(..),
81 Responses(..),
@@ -89,7 +86,6 @@ module Data.Swagger (
89 SecurityScheme(..),
86 SecurityScheme(..),
90 SecuritySchemeType(..),
87 SecuritySchemeType(..),
91 SecurityRequirement(..),
88 SecurityRequirement(..),
92− SecurityDefinitions(..),
93
89
94 -- *** API key
90 -- *** API key
95 ApiKeyParams(..),
91 ApiKeyParams(..),
@@ -114,7 +110,6 @@ module Data.Swagger (
114) where
110) where
115
111
116import Data.Swagger.Lens
112import Data.Swagger.Lens
117−import Data.Swagger.Optics ()
118import Data.Swagger.Operation
113import Data.Swagger.Operation
119import Data.Swagger.ParamSchema
114import Data.Swagger.ParamSchema
120import Data.Swagger.Schema
115import Data.Swagger.Schema
@@ -178,15 +173,13 @@ import Data.Swagger.Internal
178
173
179-- $lens
174-- $lens
180--
175--
181−-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182−--
183-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
176-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
184-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
177-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
185-- make it fairly simple to construct/modify any part of the specification:
178-- make it fairly simple to construct/modify any part of the specification:
186--
179--
187-- >>> :{
180-- >>> :{
188-- encode $ (mempty :: Swagger)
181-- encode $ (mempty :: Swagger)
189−-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]
182+-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]
190-- & paths .~
183-- & paths .~
191-- [ ("/user", mempty & get ?~ (mempty
184-- [ ("/user", mempty & get ?~ (mempty
192-- & produces ?~ MimeList ["application/json"]
185-- & produces ?~ MimeList ["application/json"]
@@ -209,7 +202,7 @@ import Data.Swagger.Internal
209-- "{\"description\":\"No content\"}"
202-- "{\"description\":\"No content\"}"
210-- >>> :{
203-- >>> :{
211-- encode $ (mempty :: Schema)
204-- encode $ (mempty :: Schema)
212−-- & type_ ?~ SwaggerBoolean
205+-- & type_ .~ SwaggerBoolean
213-- & description ?~ "To be or not to be"
206-- & description ?~ "To be or not to be"
214-- :}
207-- :}
215-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
208-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"
@@ -218,7 +211,7 @@ import Data.Swagger.Internal
218-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
211-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.
219-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
212-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:
220--
213--
221−-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber
214+-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber
222-- "{\"type\":\"number\"}"
215-- "{\"type\":\"number\"}"
223--
216--
224-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
217-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@
@@ -280,7 +273,7 @@ import Data.Swagger.Internal
280-- >>> encode $ toSchema (Proxy :: Proxy Person)
273-- >>> encode $ toSchema (Proxy :: Proxy Person)
281-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
274-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
282--
275--
283−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
276+-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a
284-- schema for basic enums like
277-- schema for basic enums like
285--
278--
286-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
279-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
@@ -293,47 +286,14 @@ import Data.Swagger.Internal
293-- >>> instance ToSchema SampleSumType
286-- >>> instance ToSchema SampleSumType
294-- >>> instance ToJSON SampleSumType
287-- >>> instance ToJSON SampleSumType
295--
288--
296−-- we can not derive a valid schema for a mix of the above. The following will result in a type error
289+-- we can not derive a valid schema for a mix of the above. The following will result in a bad schema
297−--
290+--
298−#if __GLASGOW_HASKELL__ < 800
299−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
300−-- >>> instance ToSchema BadMixedType
301−-- ...
302−-- ... error:
303−-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType
304−-- ... BadMixedType)
305−-- ... arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’
306−-- ... • In the expression:
307−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
308−-- ... In an equation for ‘declareNamedSchema’:
309−-- ... declareNamedSchema
310−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
311−-- ... In the instance declaration for ‘ToSchema BadMixedType’
312−#else
313-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
291-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
314-- >>> instance ToSchema BadMixedType
292-- >>> instance ToSchema BadMixedType
315−-- ...
316−-- ... error:
317−-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType
318−-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).
319−-- ... Swagger does not have a good representation for these types.
320−-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema
321−-- ... that matches aeson's Generic-based toJSON,
322−-- ... but that's not supported by some Swagger tools.
323−-- ... • In the expression:
324−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
325−-- ... In an equation for ‘declareNamedSchema’:
326−-- ... declareNamedSchema
327−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType
328−-- ... In the instance declaration for ‘ToSchema BadMixedType’
329−#endif
330−--
331−-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':
332−--
333−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic
334−-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
335-- >>> instance ToJSON BadMixedType
293-- >>> instance ToJSON BadMixedType
336--
294--
295+-- This is due to the fact that @'ToJSON'@ encodes empty constructors with an empty list which can not be described in a swagger schema.
296+--
337
297
338-- $manipulation
298-- $manipulation
339-- Sometimes you have to work with an imported or generated @'Swagger'@.
299-- Sometimes you have to work with an imported or generated @'Swagger'@.
src/Data/Swagger/Declare.hs+5−4
@@ -29,6 +29,7 @@ import Control.Monad.Trans.RWS.Strict as Strict
29import Control.Monad.Trans.Writer.Lazy as Lazy
29import Control.Monad.Trans.Writer.Lazy as Lazy
30import Control.Monad.Trans.Writer.Strict as Strict
30import Control.Monad.Trans.Writer.Strict as Strict
31import Data.Functor.Identity
31import Data.Functor.Identity
32+import Data.Monoid
32
33
33-- | A declare monad transformer parametrized by:
34-- | A declare monad transformer parametrized by:
34--
35--
@@ -49,15 +50,15 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where
49 pure x = DeclareT (\_ -> pure (mempty, x))
50 pure x = DeclareT (\_ -> pure (mempty, x))
50 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
51 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do
51 ~(d', f) <- df d
52 ~(d', f) <- df d
52− ~(d'', x) <- dx (mappend d d')
53+ ~(d'', x) <- dx (d <> d')
53− return (mappend d' d'', f x)
54+ return (d' <> d'', f x)
54
55
55instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
56instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where
56 return x = DeclareT (\_ -> pure (mempty, x))
57 return x = DeclareT (\_ -> pure (mempty, x))
57 DeclareT dx >>= f = DeclareT $ \d -> do
58 DeclareT dx >>= f = DeclareT $ \d -> do
58 ~(d', x) <- dx d
59 ~(d', x) <- dx d
59− ~(d'', y) <- runDeclareT (f x) (mappend d d')
60+ ~(d'', y) <- runDeclareT (f x) (d <> d')
60− return (mappend d' d'', y)
61+ return (d' <> d'', y)
61
62
62instance Monoid d => MonadTrans (DeclareT d) where
63instance Monoid d => MonadTrans (DeclareT d) where
63 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
64 lift m = DeclareT (\_ -> (,) mempty `liftM` m)
src/Data/Swagger/Internal.hs+30−147
@@ -29,19 +29,17 @@ import Control.Applicative
29import Data.Aeson
29import Data.Aeson
30import qualified Data.Aeson.Types as JSON
30import qualified Data.Aeson.Types as JSON
31import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
31import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32−import Data.Hashable (Hashable)
33import qualified Data.HashMap.Strict as HashMap
32import qualified Data.HashMap.Strict as HashMap
34−import Data.HashSet.InsOrd (InsOrdHashSet)
35import Data.Map (Map)
33import Data.Map (Map)
36import qualified Data.Map as Map
34import qualified Data.Map as Map
37−import Data.Monoid (Monoid (..))
35+import Data.Monoid
38−import Data.Semigroup.Compat (Semigroup (..))
39import Data.Scientific (Scientific)
36import Data.Scientific (Scientific)
37+import Data.Set (Set)
40import Data.String (IsString(..))
38import Data.String (IsString(..))
41import Data.Text (Text)
39import Data.Text (Text)
42import qualified Data.Text as Text
40import qualified Data.Text as Text
43import GHC.Generics (Generic)
41import GHC.Generics (Generic)
44−import Network.Socket (HostName, PortNumber)
42+import Network (HostName, PortNumber)
45import Network.HTTP.Media (MediaType)
43import Network.HTTP.Media (MediaType)
46import Text.Read (readMaybe)
44import Text.Read (readMaybe)
47
45
@@ -66,10 +64,6 @@ import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)
66#define DEFINE_TOENCODING
64#define DEFINE_TOENCODING
67#endif
65#endif
68
66
69−-- $setup
70−-- >>> :seti -XDataKinds
71−-- >>> import Data.Aeson
72−
73-- | A list of definitions that can be used in references.
67-- | A list of definitions that can be used in references.
74type Definitions = InsOrdHashMap Text
68type Definitions = InsOrdHashMap Text
75
69
@@ -117,7 +111,7 @@ data Swagger = Swagger
117 , _swaggerResponses :: Definitions Response
111 , _swaggerResponses :: Definitions Response
118
112
119 -- | Security scheme definitions that can be used across the specification.
113 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: SecurityDefinitions
114+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme
121
115
122 -- | A declaration of which security schemes are applied for the API as a whole.
116 -- | A declaration of which security schemes are applied for the API as a whole.
123 -- The list of values describes alternative security schemes that can be used
117 -- The list of values describes alternative security schemes that can be used
@@ -130,7 +124,7 @@ data Swagger = Swagger
130 -- Not all tags that are used by the Operation Object must be declared.
124 -- Not all tags that are used by the Operation Object must be declared.
131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
125 -- The tags that are not declared may be organized randomly or based on the tools' logic.
132 -- Each tag name in the list MUST be unique.
126 -- Each tag name in the list MUST be unique.
133− , _swaggerTags :: InsOrdHashSet Tag
127+ , _swaggerTags :: Set Tag
134
128
135 -- | Additional external documentation.
129 -- | Additional external documentation.
136 , _swaggerExternalDocs :: Maybe ExternalDocs
130 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -252,7 +246,7 @@ data PathItem = PathItem
252data Operation = Operation
246data Operation = Operation
253 { -- | A list of tags for API documentation control.
247 { -- | A list of tags for API documentation control.
254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
248 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
255− _operationTags :: InsOrdHashSet TagName
249+ _operationTags :: Set TagName
256
250
257 -- | A short summary of what the operation does.
251 -- | A short summary of what the operation does.
258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
252 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -309,7 +303,7 @@ data Operation = Operation
309 } deriving (Eq, Show, Generic, Data, Typeable)
303 } deriving (Eq, Show, Generic, Data, Typeable)
310
304
311newtype MimeList = MimeList { getMimeList :: [MediaType] }
305newtype MimeList = MimeList { getMimeList :: [MediaType] }
312− deriving (Eq, Show, Semigroup, Monoid, Typeable)
306+ deriving (Eq, Show, Monoid, Typeable)
313
307
314mimeListConstr :: Constr
308mimeListConstr :: Constr
315mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
309mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix
@@ -560,9 +554,9 @@ data Schema = Schema
560 , _schemaDescription :: Maybe Text
554 , _schemaDescription :: Maybe Text
561 , _schemaRequired :: [ParamName]
555 , _schemaRequired :: [ParamName]
562
556
563− , _schemaAllOf :: Maybe [Referenced Schema]
557+ , _schemaAllOf :: Maybe [Schema]
564 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
558 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)
565− , _schemaAdditionalProperties :: Maybe AdditionalProperties
559+ , _schemaAdditionalProperties :: Maybe (Referenced Schema)
566
560
567 , _schemaDiscriminator :: Maybe Text
561 , _schemaDiscriminator :: Maybe Text
568 , _schemaReadOnly :: Maybe Bool
562 , _schemaReadOnly :: Maybe Bool
@@ -594,7 +588,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
588 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.
595 _paramSchemaDefault :: Maybe Value
589 _paramSchemaDefault :: Maybe Value
596
590
597− , _paramSchemaType :: Maybe (SwaggerType t)
591+ , _paramSchemaType :: SwaggerType t
598 , _paramSchemaFormat :: Maybe Format
592 , _paramSchemaFormat :: Maybe Format
599 , _paramSchemaItems :: Maybe (SwaggerItems t)
593 , _paramSchemaItems :: Maybe (SwaggerItems t)
600 , _paramSchemaMaximum :: Maybe Scientific
594 , _paramSchemaMaximum :: Maybe Scientific
@@ -611,7 +605,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
611 , _paramSchemaMultipleOf :: Maybe Scientific
605 , _paramSchemaMultipleOf :: Maybe Scientific
612 } deriving (Eq, Show, Generic, Typeable)
606 } deriving (Eq, Show, Generic, Typeable)
613
607
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)
615
609
616data Xml = Xml
610data Xml = Xml
617 { -- | Replaces the name of the element/attribute used for the described schema property.
611 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -755,28 +749,12 @@ data SecurityScheme = SecurityScheme
755 , _securitySchemeDescription :: Maybe Text
749 , _securitySchemeDescription :: Maybe Text
756 } deriving (Eq, Show, Generic, Data, Typeable)
750 } deriving (Eq, Show, Generic, Data, Typeable)
757
751
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−
774-- | Lists the required security schemes to execute this operation.
752-- | Lists the required security schemes to execute this operation.
775-- The object can have multiple security schemes declared in it which are all required
753-- The object can have multiple security schemes declared in it which are all required
776-- (that is, there is a logical AND between the schemes).
754-- (that is, there is a logical AND between the schemes).
777newtype SecurityRequirement = SecurityRequirement
755newtype SecurityRequirement = SecurityRequirement
778 { getSecurityRequirement :: InsOrdHashMap Text [Text]
756 { 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)
780
758
781-- | Tag name.
759-- | Tag name.
782type TagName = Text
760type TagName = Text
@@ -795,8 +773,6 @@ data Tag = Tag
795 , _tagExternalDocs :: Maybe ExternalDocs
773 , _tagExternalDocs :: Maybe ExternalDocs
796 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
774 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
797
775
798−instance Hashable Tag
799−
800instance IsString Tag where
776instance IsString Tag where
801 fromString s = Tag (fromString s) Nothing Nothing
777 fromString s = Tag (fromString s) Nothing Nothing
802
778
@@ -810,8 +786,6 @@ data ExternalDocs = ExternalDocs
810 , _externalDocsUrl :: URL
786 , _externalDocsUrl :: URL
811 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
787 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
812
788
813−instance Hashable ExternalDocs
814−
815-- | A simple object to allow referencing other definitions in the specification.
789-- | A simple object to allow referencing other definitions in the specification.
816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
790-- It can be used to reference parameters and responses that are defined at the top level for reuse.
817newtype Reference = Reference { getReference :: Text }
791newtype Reference = Reference { getReference :: Text }
@@ -825,111 +799,67 @@ data Referenced a
825instance IsString a => IsString (Referenced a) where
799instance IsString a => IsString (Referenced a) where
826 fromString = Inline . fromString
800 fromString = Inline . fromString
827
801
828−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)
802+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)
829−
830−data AdditionalProperties
831− = AdditionalPropertiesAllowed Bool
832− | AdditionalPropertiesSchema (Referenced Schema)
833− deriving (Eq, Show, Data, Typeable)
834
803
835-- =======================================================================
804-- =======================================================================
836-- Monoid instances
805-- Monoid instances
837-- =======================================================================
806-- =======================================================================
838
807
839−instance Semigroup Swagger where
840− (<>) = genericMappend
841instance Monoid Swagger where
808instance Monoid Swagger where
842 mempty = genericMempty
809 mempty = genericMempty
843− mappend = (<>)
810+ mappend = genericMappend
844
811
845−instance Semigroup Info where
846− (<>) = genericMappend
847instance Monoid Info where
812instance Monoid Info where
848 mempty = genericMempty
813 mempty = genericMempty
849− mappend = (<>)
814+ mappend = genericMappend
850
815
851−instance Semigroup Contact where
852− (<>) = genericMappend
853instance Monoid Contact where
816instance Monoid Contact where
854 mempty = genericMempty
817 mempty = genericMempty
855− mappend = (<>)
818+ mappend = genericMappend
856
819
857−instance Semigroup PathItem where
858− (<>) = genericMappend
859instance Monoid PathItem where
820instance Monoid PathItem where
860 mempty = genericMempty
821 mempty = genericMempty
861− mappend = (<>)
822+ mappend = genericMappend
862
823
863−instance Semigroup Schema where
864− (<>) = genericMappend
865instance Monoid Schema where
824instance Monoid Schema where
866 mempty = genericMempty
825 mempty = genericMempty
867− mappend = (<>)
826+ mappend = genericMappend
868
827
869−instance Semigroup (ParamSchema t) where
870− (<>) = genericMappend
871instance Monoid (ParamSchema t) where
828instance Monoid (ParamSchema t) where
872 mempty = genericMempty
829 mempty = genericMempty
873− mappend = (<>)
830+ mappend = genericMappend
874
831
875−instance Semigroup Param where
876− (<>) = genericMappend
877instance Monoid Param where
832instance Monoid Param where
878 mempty = genericMempty
833 mempty = genericMempty
879− mappend = (<>)
834+ mappend = genericMappend
880
835
881−instance Semigroup ParamOtherSchema where
882− (<>) = genericMappend
883instance Monoid ParamOtherSchema where
836instance Monoid ParamOtherSchema where
884 mempty = genericMempty
837 mempty = genericMempty
885− mappend = (<>)
838+ mappend = genericMappend
886
839
887−instance Semigroup Header where
888− (<>) = genericMappend
889instance Monoid Header where
840instance Monoid Header where
890 mempty = genericMempty
841 mempty = genericMempty
891− mappend = (<>)
842+ mappend = genericMappend
892
843
893−instance Semigroup Responses where
894− (<>) = genericMappend
895instance Monoid Responses where
844instance Monoid Responses where
896 mempty = genericMempty
845 mempty = genericMempty
897− mappend = (<>)
846+ mappend = genericMappend
898
847
899−instance Semigroup Response where
900− (<>) = genericMappend
901instance Monoid Response where
848instance Monoid Response where
902 mempty = genericMempty
849 mempty = genericMempty
903− mappend = (<>)
850+ mappend = genericMappend
904
851
905−instance Semigroup ExternalDocs where
906− (<>) = genericMappend
907instance Monoid ExternalDocs where
852instance Monoid ExternalDocs where
908 mempty = genericMempty
853 mempty = genericMempty
909− mappend = (<>)
854+ mappend = genericMappend
910
855
911−instance Semigroup Operation where
912− (<>) = genericMappend
913instance Monoid Operation where
856instance Monoid Operation where
914 mempty = genericMempty
857 mempty = genericMempty
915− mappend = (<>)
858+ mappend = genericMappend
916
859
917−instance Semigroup Example where
918− (<>) = genericMappend
919instance Monoid Example where
860instance Monoid Example where
920 mempty = genericMempty
861 mempty = genericMempty
921− mappend = (<>)
862+ mappend = genericMappend
922−
923−instance Semigroup SecurityScheme where
924− (<>) = mergeSecurityScheme
925−
926−instance Semigroup SecurityDefinitions where
927− (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =
928− SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2
929−
930−instance Monoid SecurityDefinitions where
931− mempty = SecurityDefinitions $ InsOrdHashMap.empty
932− mappend = (<>)
933
863
934-- =======================================================================
864-- =======================================================================
935-- SwaggerMonoid helper instances
865-- SwaggerMonoid helper instances
@@ -945,8 +875,6 @@ instance SwaggerMonoid Responses
945instance SwaggerMonoid Response
875instance SwaggerMonoid Response
946instance SwaggerMonoid ExternalDocs
876instance SwaggerMonoid ExternalDocs
947instance SwaggerMonoid Operation
877instance SwaggerMonoid Operation
948−instance SwaggerMonoid SecurityDefinitions
949−instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
950
878
951instance SwaggerMonoid MimeList
879instance SwaggerMonoid MimeList
952deriving instance SwaggerMonoid URL
880deriving instance SwaggerMonoid URL
@@ -965,7 +893,7 @@ instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where
965
893
966instance Monoid a => SwaggerMonoid (Referenced a) where
894instance Monoid a => SwaggerMonoid (Referenced a) where
967 swaggerMempty = Inline mempty
895 swaggerMempty = Inline mempty
968− swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)
896+ swaggerMappend (Inline x) (Inline y) = Inline (x <> y)
969 swaggerMappend _ y = y
897 swaggerMappend _ y = y
970
898
971instance SwaggerMonoid ParamAnySchema where
899instance SwaggerMonoid ParamAnySchema where
@@ -1088,22 +1016,11 @@ instance ToJSON Header where
1088 toJSON = sopSwaggerGenericToJSON
1016 toJSON = sopSwaggerGenericToJSON
1089 DEFINE_TOENCODING
1017 DEFINE_TOENCODING
1090
1018
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−--
1097instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
1019instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where
1098 toJSON (SwaggerItemsPrimitive fmt schema) = object
1020 toJSON (SwaggerItemsPrimitive fmt schema) = object
1099 [ "collectionFormat" .= fmt
1021 [ "collectionFormat" .= fmt
1100 , "items" .= schema ]
1022 , "items" .= schema ]
1101 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1023 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]
1102− toJSON (SwaggerItemsArray []) = object
1103− [ "items" .= object []
1104− , "maxItems" .= (0 :: Int)
1105− , "example" .= Array mempty
1106− ]
1107 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
1024 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]
1108
1025
1109instance ToJSON Host where
1026instance ToJSON Host where
@@ -1146,9 +1063,6 @@ instance ToJSON PathItem where
1146instance ToJSON Example where
1063instance ToJSON Example where
1147 toJSON = toJSON . Map.mapKeys show . getExample
1064 toJSON = toJSON . Map.mapKeys show . getExample
1148
1065
1149−instance ToJSON SecurityDefinitions where
1150− toJSON (SecurityDefinitions sd) = toJSON sd
1151−
1152instance ToJSON Reference where
1066instance ToJSON Reference where
1153 toJSON (Reference ref) = object [ "$ref" .= ref ]
1067 toJSON (Reference ref) = object [ "$ref" .= ref ]
1154
1068
@@ -1182,10 +1096,6 @@ instance ToJSON (ParamSchema k) where
1182 toJSON = sopSwaggerGenericToJSONWithOpts $
1096 toJSON = sopSwaggerGenericToJSONWithOpts $
1183 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1097 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"
1184
1098
1185−instance ToJSON AdditionalProperties where
1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b
1187− toJSON (AdditionalPropertiesSchema s) = toJSON s
1188−
1189-- =======================================================================
1099-- =======================================================================
1190-- Manual FromJSON instances
1100-- Manual FromJSON instances
1191-- =======================================================================
1101-- =======================================================================
@@ -1223,13 +1133,7 @@ instance FromJSON SecurityScheme where
1223 parseJSON = sopSwaggerGenericParseJSON
1133 parseJSON = sopSwaggerGenericParseJSON
1224
1134
1225instance FromJSON Schema where
1135instance FromJSON Schema where
1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON
1136+ parseJSON = sopSwaggerGenericParseJSON
1227− where nullaryCleanup :: Schema -> Schema
1228− nullaryCleanup s@Schema{_schemaParamSchema=ps} =
1229− if _paramSchemaItems ps == Just (SwaggerItemsArray [])
1230− then s { _schemaExample = Nothing
1231− , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }
1232− else s
1233
1137
1234instance FromJSON Header where
1138instance FromJSON Header where
1235 parseJSON = sopSwaggerGenericParseJSON
1139 parseJSON = sopSwaggerGenericParseJSON
@@ -1244,21 +1148,8 @@ instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where
1244 <$> o .:? "collectionFormat"
1148 <$> o .:? "collectionFormat"
1245 <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1149 <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))
1246
1150
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−--
1258instance FromJSON (SwaggerItems 'SwaggerKindSchema) where
1151instance 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
1262 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1153 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js
1263 parseJSON _ = empty
1154 parseJSON _ = empty
1264
1155
@@ -1310,9 +1201,6 @@ instance FromJSON Operation where
1310instance FromJSON PathItem where
1201instance FromJSON PathItem where
1311 parseJSON = sopSwaggerGenericParseJSON
1202 parseJSON = sopSwaggerGenericParseJSON
1312
1203
1313−instance FromJSON SecurityDefinitions where
1314− parseJSON js = SecurityDefinitions <$> parseJSON js
1315−
1316instance FromJSON Reference where
1204instance FromJSON Reference where
1317 parseJSON (Object o) = Reference <$> o .: "$ref"
1205 parseJSON (Object o) = Reference <$> o .: "$ref"
1318 parseJSON _ = empty
1206 parseJSON _ = empty
@@ -1363,10 +1251,6 @@ instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where
1363instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1251instance FromJSON (ParamSchema 'SwaggerKindSchema) where
1364 parseJSON = sopSwaggerGenericParseJSON
1252 parseJSON = sopSwaggerGenericParseJSON
1365
1253
1366−instance FromJSON AdditionalProperties where
1367− parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b
1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js
1369−
1370-------------------------------------------------------------------------------
1254-------------------------------------------------------------------------------
1371-- TH splices
1255-- TH splices
1372-------------------------------------------------------------------------------
1256-------------------------------------------------------------------------------
@@ -1424,4 +1308,3 @@ instance AesonDefaultValue (SwaggerType a)
1424instance AesonDefaultValue MimeList where defaultValue = Just mempty
1308instance AesonDefaultValue MimeList where defaultValue = Just mempty
1425instance AesonDefaultValue Info
1309instance AesonDefaultValue Info
1426instance AesonDefaultValue ParamLocation
1310instance 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
44import qualified Data.HashMap.Strict as HM
44import qualified Data.HashMap.Strict as HM
45import qualified Data.Set as Set
45import qualified Data.Set as Set
46import qualified Data.HashMap.Strict.InsOrd as InsOrd
46import qualified Data.HashMap.Strict.InsOrd as InsOrd
47−import qualified Data.HashSet.InsOrd as InsOrdHS
48
47
49#if MIN_VERSION_aeson(0,10,0)
48#if MIN_VERSION_aeson(0,10,0)
50import Data.Aeson (Encoding, pairs, (.=), Series)
49import Data.Aeson (Encoding, pairs, (.=), Series)
50+import Data.Monoid ((<>))
51#endif
51#endif
52
52
53-------------------------------------------------------------------------------
53-------------------------------------------------------------------------------
@@ -68,10 +68,10 @@ mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing
68makeLenses ''SwaggerAesonOptions
68makeLenses ''SwaggerAesonOptions
69
69
70class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
70class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where
71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions
71+ swaggerAesonOptions :: proxy a -> SwaggerAesonOptions
72
72
73 -- So far we use only default definitions
73 -- So far we use only default definitions
74− aesonDefaults :: Proxy a -> POP Maybe (Code a)
74+ aesonDefaults :: proxy a -> POP Maybe (Code a)
75 aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
75 aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue
76
76
77-------------------------------------------------------------------------------
77-------------------------------------------------------------------------------
@@ -86,7 +86,6 @@ instance AesonDefaultValue Text where defaultValue = Nothing
86instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
86instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
87instance AesonDefaultValue [a] where defaultValue = Just []
87instance AesonDefaultValue [a] where defaultValue = Just []
88instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
88instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
89−instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty
90instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
89instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
91
90
92-------------------------------------------------------------------------------
91-------------------------------------------------------------------------------
@@ -146,11 +145,7 @@ sopSwaggerGenericToJSON'
146 -> DatatypeInfo '[xs]
145 -> DatatypeInfo '[xs]
147 -> POP Maybe '[xs]
146 -> POP Maybe '[xs]
148 -> [Pair]
147 -> [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
152sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
148sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
153−#endif
154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
149 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
155sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
150sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
156
151
@@ -226,11 +221,7 @@ sopSwaggerGenericParseJSON'
226 -> DatatypeInfo '[xs]
221 -> DatatypeInfo '[xs]
227 -> POP Maybe '[xs]
222 -> POP Maybe '[xs]
228 -> Parser (SOP I '[xs])
223 -> 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
232sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
224sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
233−#endif
234 SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
225 SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
235sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
226sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
236
227
@@ -302,11 +293,7 @@ sopSwaggerGenericToEncoding'
302 -> DatatypeInfo '[xs]
293 -> DatatypeInfo '[xs]
303 -> POP Maybe '[xs]
294 -> POP Maybe '[xs]
304 -> Series
295 -> 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
308sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
296sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
309−#endif
310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
297 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
311sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
298sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
312
299
src/Data/Swagger/Internal/ParamSchema.hs+25−60
@@ -22,7 +22,7 @@
22module Data.Swagger.Internal.ParamSchema where
22module Data.Swagger.Internal.ParamSchema where
23
23
24import Control.Lens
24import Control.Lens
25−import Data.Aeson (ToJSON (..))
25+import Data.Aeson
26import Data.Proxy
26import Data.Proxy
27import GHC.Generics
27import GHC.Generics
28
28
@@ -31,7 +31,6 @@ import "unordered-containers" Data.HashSet (HashSet)
31import Data.Monoid
31import Data.Monoid
32import Data.Set (Set)
32import Data.Set (Set)
33import Data.Scientific
33import Data.Scientific
34−import Data.Fixed (HasResolution(..), Fixed, Pico)
35import qualified Data.Text as T
34import qualified Data.Text as T
36import qualified Data.Text.Lazy as TL
35import qualified Data.Text.Lazy as TL
37import Data.Time
36import Data.Time
@@ -39,11 +38,8 @@ import qualified Data.Vector as V
39import qualified Data.Vector.Primitive as VP
38import qualified Data.Vector.Primitive as VP
40import qualified Data.Vector.Storable as VS
39import qualified Data.Vector.Storable as VS
41import qualified Data.Vector.Unboxed as VU
40import qualified Data.Vector.Unboxed as VU
42−import Data.Version (Version)
43−import Numeric.Natural.Compat (Natural)
44import Data.Word
41import Data.Word
45import Data.UUID.Types (UUID)
42import Data.UUID.Types (UUID)
46−import Web.Cookie (SetCookie)
47
43
48import Data.Swagger.Internal
44import Data.Swagger.Internal
49import Data.Swagger.Lens
45import Data.Swagger.Lens
@@ -59,20 +55,20 @@ import GHC.TypeLits (TypeError, ErrorMessage(..))
59-- | Default schema for binary data (any sequence of octets).
55-- | Default schema for binary data (any sequence of octets).
60binaryParamSchema :: ParamSchema t
56binaryParamSchema :: ParamSchema t
61binaryParamSchema = mempty
57binaryParamSchema = mempty
62− & type_ ?~ SwaggerString
58+ & type_ .~ SwaggerString
63 & format ?~ "binary"
59 & format ?~ "binary"
64
60
65-- | Default schema for binary data (base64 encoded).
61-- | Default schema for binary data (base64 encoded).
66byteParamSchema :: ParamSchema t
62byteParamSchema :: ParamSchema t
67byteParamSchema = mempty
63byteParamSchema = mempty
68− & type_ ?~ SwaggerString
64+ & type_ .~ SwaggerString
69 & format ?~ "byte"
65 & format ?~ "byte"
70
66
71-- | Default schema for password string.
67-- | Default schema for password string.
72-- @"password"@ format is used to hint UIs the input needs to be obscured.
68-- @"password"@ format is used to hint UIs the input needs to be obscured.
73passwordParamSchema :: ParamSchema t
69passwordParamSchema :: ParamSchema t
74passwordParamSchema = mempty
70passwordParamSchema = mempty
75− & type_ ?~ SwaggerString
71+ & type_ .~ SwaggerString
76 & format ?~ "password"
72 & format ?~ "password"
77
73
78-- | Convert a type into a plain @'ParamSchema'@.
74-- | Convert a type into a plain @'ParamSchema'@.
@@ -88,7 +84,7 @@ passwordParamSchema = mempty
88--
84--
89-- instance ToParamSchema Direction where
85-- instance ToParamSchema Direction where
90-- toParamSchema _ = mempty
86-- toParamSchema _ = mempty
91−-- & type_ ?~ SwaggerString
87+-- & type_ .~ SwaggerString
92-- & enum_ ?~ [ \"Up\", \"Down\" ]
88-- & enum_ ?~ [ \"Up\", \"Down\" ]
93-- @
89-- @
94--
90--
@@ -115,24 +111,18 @@ class ToParamSchema a where
115 --
111 --
116 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
112 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)
117 -- "{\"type\":\"integer\"}"
113 -- "{\"type\":\"integer\"}"
118− toParamSchema :: Proxy a -> ParamSchema t
114+ toParamSchema :: proxy a -> ParamSchema t
119− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t
115+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t
120 toParamSchema = genericToParamSchema defaultSchemaOptions
116 toParamSchema = genericToParamSchema defaultSchemaOptions
121
117
122instance OVERLAPPING_ ToParamSchema String where
118instance OVERLAPPING_ ToParamSchema String where
123− toParamSchema _ = mempty & type_ ?~ SwaggerString
119+ toParamSchema _ = mempty & type_ .~ SwaggerString
124
120
125instance ToParamSchema Bool where
121instance ToParamSchema Bool where
126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean
122+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean
127
123
128instance ToParamSchema Integer where
124instance ToParamSchema Integer where
129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger
125+ toParamSchema _ = mempty & type_ .~ SwaggerInteger
130−
131−instance ToParamSchema Natural where
132− toParamSchema _ = mempty
133− & type_ ?~ SwaggerInteger
134− & minimum_ ?~ 0
135− & exclusiveMinimum ?~ False
136
126
137instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
127instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral
138instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
128instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral
@@ -154,51 +144,40 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral
154--
144--
155-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
145-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)
156-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
146-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t
147+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t
158toParamSchemaBoundedIntegral _ = mempty
148toParamSchemaBoundedIntegral _ = mempty
159− & type_ ?~ SwaggerInteger
149+ & type_ .~ SwaggerInteger
160 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
150 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
161 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
151 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
162
152
163instance ToParamSchema Char where
153instance ToParamSchema Char where
164 toParamSchema _ = mempty
154 toParamSchema _ = mempty
165− & type_ ?~ SwaggerString
155+ & type_ .~ SwaggerString
166 & maxLength ?~ 1
156 & maxLength ?~ 1
167 & minLength ?~ 1
157 & minLength ?~ 1
168
158
169instance ToParamSchema Scientific where
159instance ToParamSchema Scientific where
170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber
160+ toParamSchema _ = mempty & type_ .~ SwaggerNumber
171−
172−instance HasResolution a => ToParamSchema (Fixed a) where
173− toParamSchema _ = mempty
174− & type_ ?~ SwaggerNumber
175− & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))
176
161
177instance ToParamSchema Double where
162instance ToParamSchema Double where
178 toParamSchema _ = mempty
163 toParamSchema _ = mempty
179− & type_ ?~ SwaggerNumber
164+ & type_ .~ SwaggerNumber
180 & format ?~ "double"
165 & format ?~ "double"
181
166
182instance ToParamSchema Float where
167instance ToParamSchema Float where
183 toParamSchema _ = mempty
168 toParamSchema _ = mempty
184− & type_ ?~ SwaggerNumber
169+ & type_ .~ SwaggerNumber
185 & format ?~ "float"
170 & format ?~ "float"
186
171
187timeParamSchema :: String -> ParamSchema t
172timeParamSchema :: String -> ParamSchema t
188timeParamSchema fmt = mempty
173timeParamSchema fmt = mempty
189− & type_ ?~ SwaggerString
174+ & type_ .~ SwaggerString
190 & format ?~ T.pack fmt
175 & format ?~ T.pack fmt
191
176
192-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
177-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
193instance ToParamSchema Day where
178instance ToParamSchema Day where
194 toParamSchema _ = timeParamSchema "date"
179 toParamSchema _ = timeParamSchema "date"
195
180
196−-- |
197−-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198−-- Just "hh:MM:ss"
199−instance ToParamSchema TimeOfDay where
200− toParamSchema _ = timeParamSchema "hh:MM:ss"
201−
202-- |
181-- |
203-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
182-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
204-- Just "yyyy-mm-ddThh:MM:ss"
183-- Just "yyyy-mm-ddThh:MM:ss"
@@ -218,7 +197,7 @@ instance ToParamSchema UTCTime where
218 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
197 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"
219
198
220instance ToParamSchema NominalDiffTime where
199instance ToParamSchema NominalDiffTime where
221− toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)
200+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)
222
201
223instance ToParamSchema T.Text where
202instance ToParamSchema T.Text where
224 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
203 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
@@ -226,16 +205,6 @@ instance ToParamSchema T.Text where
226instance ToParamSchema TL.Text where
205instance ToParamSchema TL.Text where
227 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
206 toParamSchema _ = toParamSchema (Proxy :: Proxy String)
228
207
229−instance ToParamSchema Version where
230− toParamSchema _ = mempty
231− & type_ ?~ SwaggerString
232− & pattern ?~ "^\\d+(\\.\\d+)*$"
233−
234−instance ToParamSchema SetCookie where
235− toParamSchema _ = mempty
236− & type_ ?~ SwaggerString
237−
238−
239#if __GLASGOW_HASKELL__ < 800
208#if __GLASGOW_HASKELL__ < 800
240#else
209#else
241type family ToParamSchemaByteStringError bs where
210type family ToParamSchemaByteStringError bs where
@@ -256,11 +225,9 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to
256instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
225instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
257instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
226instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
258
227
259−instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)
260−
261instance ToParamSchema a => ToParamSchema [a] where
228instance ToParamSchema a => ToParamSchema [a] where
262 toParamSchema _ = mempty
229 toParamSchema _ = mempty
263− & type_ ?~ SwaggerArray
230+ & type_ .~ SwaggerArray
264 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
231 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))
265
232
266instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
233instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])
@@ -280,12 +247,12 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where
280-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
247-- "{\"type\":\"string\",\"enum\":[\"_\"]}"
281instance ToParamSchema () where
248instance ToParamSchema () where
282 toParamSchema _ = mempty
249 toParamSchema _ = mempty
283− & type_ ?~ SwaggerString
250+ & type_ .~ SwaggerString
284 & enum_ ?~ ["_"]
251 & enum_ ?~ ["_"]
285
252
286instance ToParamSchema UUID where
253instance ToParamSchema UUID where
287 toParamSchema _ = mempty
254 toParamSchema _ = mempty
288− & type_ ?~ SwaggerString
255+ & type_ .~ SwaggerString
289 & format ?~ "uuid"
256 & format ?~ "uuid"
290
257
291-- | A configurable generic @'ParamSchema'@ creator.
258-- | A configurable generic @'ParamSchema'@ creator.
@@ -294,11 +261,11 @@ instance ToParamSchema UUID where
294-- >>> data Color = Red | Blue deriving Generic
261-- >>> data Color = Red | Blue deriving Generic
295-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
262-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)
296-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
263-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"
297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t
264+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t
298genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
265genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty
299
266
300class GToParamSchema (f :: * -> *) where
267class GToParamSchema (f :: * -> *) where
301− gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
268+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
302
269
303instance GToParamSchema f => GToParamSchema (D1 d f) where
270instance GToParamSchema f => GToParamSchema (D1 d f) where
304 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
271 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)
@@ -316,14 +283,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh
316 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
283 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))
317
284
318class GEnumParamSchema (f :: * -> *) where
285class GEnumParamSchema (f :: * -> *) where
319− genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t
286+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t
320
287
321instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
288instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where
322 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
289 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)
323
290
324instance Constructor c => GEnumParamSchema (C1 c U1) where
291instance Constructor c => GEnumParamSchema (C1 c U1) where
325 genumParamSchema opts _ s = s
292 genumParamSchema opts _ s = s
326− & type_ ?~ SwaggerString
293+ & type_ .~ SwaggerString
327 & enum_ %~ addEnumValue tag
294 & enum_ %~ addEnumValue tag
328 where
295 where
329 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
296 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
@@ -333,5 +300,3 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where
333
300
334data Proxy3 a b c = Proxy3
301data Proxy3 a b c = Proxy3
335
302
336−-- $setup
337−-- >>> import Data.Aeson (encode)
src/Data/Swagger/Internal/Schema.hs+67−181
@@ -1,5 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -32,7 +31,7 @@ import Data.Data.Lens (template)
32
31
33import Control.Monad
32import Control.Monad
34import Control.Monad.Writer
33import Control.Monad.Writer
35−import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
34+import Data.Aeson
36import Data.Char
35import Data.Char
37import Data.Data (Data)
36import Data.Data (Data)
38import Data.Foldable (traverse_)
37import Data.Foldable (traverse_)
@@ -44,11 +43,9 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
44import Data.Int
43import Data.Int
45import Data.IntSet (IntSet)
44import Data.IntSet (IntSet)
46import Data.IntMap (IntMap)
45import Data.IntMap (IntMap)
47−import Data.List.NonEmpty.Compat (NonEmpty)
48import Data.Map (Map)
46import Data.Map (Map)
49import Data.Proxy
47import Data.Proxy
50import Data.Scientific (Scientific)
48import Data.Scientific (Scientific)
51−import Data.Fixed (Fixed, HasResolution, Pico)
52import Data.Set (Set)
49import Data.Set (Set)
53import qualified Data.Text as T
50import qualified Data.Text as T
54import qualified Data.Text.Lazy as TL
51import qualified Data.Text.Lazy as TL
@@ -57,8 +54,6 @@ import qualified Data.Vector as V
57import qualified Data.Vector.Primitive as VP
54import qualified Data.Vector.Primitive as VP
58import qualified Data.Vector.Storable as VS
55import qualified Data.Vector.Storable as VS
59import qualified Data.Vector.Unboxed as VU
56import qualified Data.Vector.Unboxed as VU
60−import Data.Version (Version)
61−import Numeric.Natural.Compat (Natural)
62import Data.Word
57import Data.Word
63import GHC.Generics
58import GHC.Generics
64import qualified Data.UUID.Types as UUID
59import qualified Data.UUID.Types as UUID
@@ -69,7 +64,6 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
69import Data.Swagger.Lens hiding (name, schema)
64import Data.Swagger.Lens hiding (name, schema)
70import qualified Data.Swagger.Lens as Swagger
65import qualified Data.Swagger.Lens as Swagger
71import Data.Swagger.SchemaOptions
66import Data.Swagger.SchemaOptions
72−import Data.Swagger.Internal.TypeShape
73
67
74#if __GLASGOW_HASKELL__ < 800
68#if __GLASGOW_HASKELL__ < 800
75#else
69#else
@@ -111,7 +105,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema
111-- declareNamedSchema _ = do
105-- declareNamedSchema _ = do
112-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
106-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
113-- return $ NamedSchema (Just \"Coord\") $ mempty
107-- return $ NamedSchema (Just \"Coord\") $ mempty
114−-- & type_ ?~ SwaggerObject
108+-- & type_ .~ SwaggerObject
115-- & properties .~
109-- & properties .~
116-- [ (\"x\", doubleSchema)
110-- [ (\"x\", doubleSchema)
117-- , (\"y\", doubleSchema)
111-- , (\"y\", doubleSchema)
@@ -142,17 +136,12 @@ class ToSchema a where
142 -- together with all used definitions.
136 -- together with all used definitions.
143 -- Note that the schema itself is included in definitions
137 -- Note that the schema itself is included in definitions
144 -- only if it is recursive (and thus needs its definition in scope).
138 -- only if it is recursive (and thus needs its definition in scope).
145− declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
139+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema
146− default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
147− Proxy a -> Declare (Definitions Schema) NamedSchema
140+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema
148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
141 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149
142
150−instance ToSchema TimeOfDay where
151− declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152− & example ?~ toJSON (TimeOfDay 12 33 15)
153−
154-- | Convert a type into a schema and declare all used schema definitions.
143-- | Convert a type into a schema and declare all used schema definitions.
155−declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
144+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema
156declareSchema = fmap _namedSchemaSchema . declareNamedSchema
145declareSchema = fmap _namedSchemaSchema . declareNamedSchema
157
146
158-- | Convert a type into an optionally named schema.
147-- | Convert a type into an optionally named schema.
@@ -166,7 +155,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema
166-- Just "Day"
155-- Just "Day"
167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
156-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
168-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
157-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
158+toNamedSchema :: ToSchema a => proxy a -> NamedSchema
170toNamedSchema = undeclare . declareNamedSchema
159toNamedSchema = undeclare . declareNamedSchema
171
160
172-- | Get type's schema name according to its @'ToSchema'@ instance.
161-- | Get type's schema name according to its @'ToSchema'@ instance.
@@ -176,7 +165,7 @@ toNamedSchema = undeclare . declareNamedSchema
176--
165--
177-- >>> schemaName (Proxy :: Proxy UTCTime)
166-- >>> schemaName (Proxy :: Proxy UTCTime)
178-- Just "UTCTime"
167-- Just "UTCTime"
179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text
168+schemaName :: ToSchema a => proxy a -> Maybe T.Text
180schemaName = _namedSchemaName . toNamedSchema
169schemaName = _namedSchemaName . toNamedSchema
181
170
182-- | Convert a type into a schema.
171-- | Convert a type into a schema.
@@ -186,7 +175,7 @@ schemaName = _namedSchemaName . toNamedSchema
186--
175--
187-- >>> encode $ toSchema (Proxy :: Proxy [Day])
176-- >>> encode $ toSchema (Proxy :: Proxy [Day])
188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
177-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
189−toSchema :: ToSchema a => Proxy a -> Schema
178+toSchema :: ToSchema a => proxy a -> Schema
190toSchema = _namedSchemaSchema . toNamedSchema
179toSchema = _namedSchemaSchema . toNamedSchema
191
180
192-- | Convert a type into a referenced schema if possible.
181-- | Convert a type into a referenced schema if possible.
@@ -197,7 +186,7 @@ toSchema = _namedSchemaSchema . toNamedSchema
197--
186--
198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
187-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
199-- "{\"$ref\":\"#/definitions/Day\"}"
188-- "{\"$ref\":\"#/definitions/Day\"}"
200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
189+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema
201toSchemaRef = undeclare . declareSchemaRef
190toSchemaRef = undeclare . declareSchemaRef
202
191
203-- | Convert a type into a referenced schema if possible
192-- | Convert a type into a referenced schema if possible
@@ -207,7 +196,7 @@ toSchemaRef = undeclare . declareSchemaRef
207-- Schema definitions are typically declared for every referenced schema.
196-- Schema definitions are typically declared for every referenced schema.
208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
197-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
209-- will be declared (regardless of whether it is recusive or not).
198-- will be declared (regardless of whether it is recusive or not).
210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
199+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)
211declareSchemaRef proxy = do
200declareSchemaRef proxy = do
212 case toNamedSchema proxy of
201 case toNamedSchema proxy of
213 NamedSchema (Just name) schema -> do
202 NamedSchema (Just name) schema -> do
@@ -269,7 +258,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)
269--
258--
270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
259-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
271-- when inlining recursive schemas.
260-- when inlining recursive schemas.
272−toInlinedSchema :: ToSchema a => Proxy a -> Schema
261+toInlinedSchema :: ToSchema a => proxy a -> Schema
273toInlinedSchema proxy = inlineAllSchemas defs schema
262toInlinedSchema proxy = inlineAllSchemas defs schema
274 where
263 where
275 (defs, schema) = runDeclare (declareSchema proxy) mempty
264 (defs, schema) = runDeclare (declareSchema proxy) mempty
@@ -298,20 +287,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
298-- | Default schema for binary data (any sequence of octets).
287-- | Default schema for binary data (any sequence of octets).
299binarySchema :: Schema
288binarySchema :: Schema
300binarySchema = mempty
289binarySchema = mempty
301− & type_ ?~ SwaggerString
290+ & type_ .~ SwaggerString
302 & format ?~ "binary"
291 & format ?~ "binary"
303
292
304-- | Default schema for binary data (base64 encoded).
293-- | Default schema for binary data (base64 encoded).
305byteSchema :: Schema
294byteSchema :: Schema
306byteSchema = mempty
295byteSchema = mempty
307− & type_ ?~ SwaggerString
296+ & type_ .~ SwaggerString
308 & format ?~ "byte"
297 & format ?~ "byte"
309
298
310-- | Default schema for password string.
299-- | Default schema for password string.
311-- @"password"@ format is used to hint UIs the input needs to be obscured.
300-- @"password"@ format is used to hint UIs the input needs to be obscured.
312passwordSchema :: Schema
301passwordSchema :: Schema
313passwordSchema = mempty
302passwordSchema = mempty
314− & type_ ?~ SwaggerString
303+ & type_ .~ SwaggerString
315 & format ?~ "password"
304 & format ?~ "password"
316
305
317-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
306-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
@@ -337,12 +326,12 @@ sketchSchema = sketch . toJSON
337 sketch js@(Bool _) = go js
326 sketch js@(Bool _) = go js
338 sketch js = go js & example ?~ js
327 sketch js = go js & example ?~ js
339
328
340− go Null = mempty & type_ ?~ SwaggerNull
329+ go Null = mempty & type_ .~ SwaggerNull
341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean
330+ go (Bool _) = mempty & type_ .~ SwaggerBoolean
342− go (String _) = mempty & type_ ?~ SwaggerString
331+ go (String _) = mempty & type_ .~ SwaggerString
343− go (Number _) = mempty & type_ ?~ SwaggerNumber
332+ go (Number _) = mempty & type_ .~ SwaggerNumber
344 go (Array xs) = mempty
333 go (Array xs) = mempty
345− & type_ ?~ SwaggerArray
334+ & type_ .~ SwaggerArray
346 & items ?~ case ischema of
335 & items ?~ case ischema of
347 Just s -> SwaggerItemsObject (Inline s)
336 Just s -> SwaggerItemsObject (Inline s)
348 _ -> SwaggerItemsArray (map Inline ys)
337 _ -> SwaggerItemsArray (map Inline ys)
@@ -354,7 +343,7 @@ sketchSchema = sketch . toJSON
354 (z:_) | allSame -> Just z
343 (z:_) | allSame -> Just z
355 _ -> Nothing
344 _ -> Nothing
356 go (Object o) = mempty
345 go (Object o) = mempty
357− & type_ ?~ SwaggerObject
346+ & type_ .~ SwaggerObject
358 & required .~ HashMap.keys o
347 & required .~ HashMap.keys o
359 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
348 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
360
349
@@ -377,24 +366,24 @@ sketchSchema = sketch . toJSON
377sketchStrictSchema :: ToJSON a => a -> Schema
366sketchStrictSchema :: ToJSON a => a -> Schema
378sketchStrictSchema = go . toJSON
367sketchStrictSchema = go . toJSON
379 where
368 where
380− go Null = mempty & type_ ?~ SwaggerNull
369+ go Null = mempty & type_ .~ SwaggerNull
381 go js@(Bool _) = mempty
370 go js@(Bool _) = mempty
382− & type_ ?~ SwaggerBoolean
371+ & type_ .~ SwaggerBoolean
383 & enum_ ?~ [js]
372 & enum_ ?~ [js]
384 go js@(String s) = mempty
373 go js@(String s) = mempty
385− & type_ ?~ SwaggerString
374+ & type_ .~ SwaggerString
386 & maxLength ?~ fromIntegral (T.length s)
375 & maxLength ?~ fromIntegral (T.length s)
387 & minLength ?~ fromIntegral (T.length s)
376 & minLength ?~ fromIntegral (T.length s)
388 & pattern ?~ s
377 & pattern ?~ s
389 & enum_ ?~ [js]
378 & enum_ ?~ [js]
390 go js@(Number n) = mempty
379 go js@(Number n) = mempty
391− & type_ ?~ SwaggerNumber
380+ & type_ .~ SwaggerNumber
392 & maximum_ ?~ n
381 & maximum_ ?~ n
393 & minimum_ ?~ n
382 & minimum_ ?~ n
394 & multipleOf ?~ n
383 & multipleOf ?~ n
395 & enum_ ?~ [js]
384 & enum_ ?~ [js]
396 go js@(Array xs) = mempty
385 go js@(Array xs) = mempty
397− & type_ ?~ SwaggerArray
386+ & type_ .~ SwaggerArray
398 & maxItems ?~ fromIntegral sz
387 & maxItems ?~ fromIntegral sz
399 & minItems ?~ fromIntegral sz
388 & minItems ?~ fromIntegral sz
400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
389 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
@@ -404,7 +393,7 @@ sketchStrictSchema = go . toJSON
404 sz = length xs
393 sz = length xs
405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
394 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
406 go js@(Object o) = mempty
395 go js@(Object o) = mempty
407− & type_ ?~ SwaggerObject
396+ & type_ .~ SwaggerObject
408 & required .~ names
397 & required .~ names
409 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
398 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
410 & maxProperties ?~ fromIntegral (length names)
399 & maxProperties ?~ fromIntegral (length names)
@@ -414,19 +403,18 @@ sketchStrictSchema = go . toJSON
414 names = HashMap.keys o
403 names = HashMap.keys o
415
404
416class GToSchema (f :: * -> *) where
405class GToSchema (f :: * -> *) where
417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
406+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
418
407
419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
408instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where
420 declareNamedSchema _ = do
409 declareNamedSchema _ = do
421 ref <- declareSchemaRef (Proxy :: Proxy a)
410 ref <- declareSchemaRef (Proxy :: Proxy a)
422 return $ unnamed $ mempty
411 return $ unnamed $ mempty
423− & type_ ?~ SwaggerArray
412+ & type_ .~ SwaggerArray
424 & items ?~ SwaggerItemsObject ref
413 & items ?~ SwaggerItemsObject ref
425
414
426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
415instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
416instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema
428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
417instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
418instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema
431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
419instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema
432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
420instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema
@@ -446,8 +434,6 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc
446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
434instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema
447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
435instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema
448
436
449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema
450−
451instance ToSchema a => ToSchema (Maybe a) where
437instance ToSchema a => ToSchema (Maybe a) where
452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
438 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
453
439
@@ -470,7 +456,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f
470
456
471timeSchema :: T.Text -> Schema
457timeSchema :: T.Text -> Schema
472timeSchema fmt = mempty
458timeSchema fmt = mempty
473− & type_ ?~ SwaggerString
459+ & type_ .~ SwaggerString
474 & format ?~ fmt
460 & format ?~ fmt
475
461
476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
462-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
@@ -491,7 +477,7 @@ instance ToSchema ZonedTime where
491 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
477 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))
492
478
493instance ToSchema NominalDiffTime where
479instance ToSchema NominalDiffTime where
494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)
480+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)
495
481
496-- |
482-- |
497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
483-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
@@ -503,8 +489,6 @@ instance ToSchema UTCTime where
503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
489instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
490instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema
505
491
506−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema
507−
508#if __GLASGOW_HASKELL__ < 800
492#if __GLASGOW_HASKELL__ < 800
509#else
493#else
510type family ToSchemaByteStringError bs where
494type family ToSchemaByteStringError bs where
@@ -532,8 +516,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
532 declareObjectMapSchema = do
516 declareObjectMapSchema = do
533 schema <- declareSchemaRef (Proxy :: Proxy v)
517 schema <- declareSchemaRef (Proxy :: Proxy v)
534 return $ unnamed $ mempty
518 return $ unnamed $ mempty
535− & type_ ?~ SwaggerObject
519+ & type_ .~ SwaggerObject
536− & additionalProperties ?~ AdditionalPropertiesSchema schema
520+ & additionalProperties ?~ schema
537
521
538instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
522instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
539 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
523 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))
@@ -544,7 +528,7 @@ instance ToSchema a => ToSchema (Map String a) where
544 declareNamedSchema _ = do
528 declareNamedSchema _ = do
545 schema <- declareSchemaRef (Proxy :: Proxy a)
529 schema <- declareSchemaRef (Proxy :: Proxy a)
546 return $ unnamed $ mempty
530 return $ unnamed $ mempty
547− & type_ ?~ SwaggerObject
531+ & type_ .~ SwaggerObject
548 & additionalProperties ?~ schema
532 & additionalProperties ?~ schema
549
533
550instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
534instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))
@@ -556,12 +540,6 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =
556
540
557#endif
541#endif
558
542
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−
565instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
543instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
566instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
544instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
567instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
545instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
@@ -575,13 +553,6 @@ instance ToSchema a => ToSchema (Set a) where
575
553
576instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
554instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))
577
555
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−
585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
556instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
557instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema
587
558
@@ -591,141 +562,61 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname
591instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
562instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
592instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
563instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
593
564
594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)
595−
596-- | Default schema for @'Bounded'@, @'Integral'@ types.
565-- | Default schema for @'Bounded'@, @'Integral'@ types.
597--
566--
598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
567-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
568-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
569+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema
601toSchemaBoundedIntegral _ = mempty
570toSchemaBoundedIntegral _ = mempty
602− & type_ ?~ SwaggerInteger
571+ & type_ .~ SwaggerInteger
603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
572 & minimum_ ?~ fromInteger (toInteger (minBound :: a))
604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
573 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))
605
574
606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
575-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
607−genericToNamedSchemaBoundedIntegral :: forall a d f.
576+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.
608 ( Bounded a, Integral a
577 ( Bounded a, Integral a
609 , Generic a, Rep a ~ D1 d f, Datatype d)
578 , Generic a, Rep a ~ D1 d f, Datatype d)
610− => SchemaOptions -> Proxy a -> NamedSchema
579+ => SchemaOptions -> proxy a -> NamedSchema
611genericToNamedSchemaBoundedIntegral opts proxy
580genericToNamedSchemaBoundedIntegral opts proxy
612− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)
581+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)
613−
614−-- | Declare a named schema for a @newtype@ wrapper.
615−genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
616− (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
617− => SchemaOptions -- ^ How to derive the name.
618− -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.
619− -> Proxy a
620− -> Declare (Definitions Schema) NamedSchema
621−genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)
622−
623−-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
624−-- This makes a much more useful schema when there aren't many options for key values.
625−--
626−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
627−-- >>> instance ToJSON ButtonState
628−-- >>> instance ToSchema ButtonState
629−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
630−-- >>> type ImageUrl = T.Text
631−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
632−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
633−--
634−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
635−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
636−declareSchemaBoundedEnumKeyMapping :: forall map key value.
637− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
638− => Proxy (map key value) -> Declare (Definitions Schema) Schema
639−declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
640− ToJSONKeyText keyToText _ -> objectSchema keyToText
641− ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
642− where
643− objectSchema keyToText = do
644− valueRef <- declareSchemaRef (Proxy :: Proxy value)
645− let allKeys = [minBound..maxBound :: key]
646− mkPair k = (keyToText k, valueRef)
647− return $ mempty
648− & type_ ?~ SwaggerObject
649− & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)
650−
651−-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
652−-- This makes a much more useful schema when there aren't many options for key values.
653−--
654−-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
655−-- >>> instance ToJSON ButtonState
656−-- >>> instance ToSchema ButtonState
657−-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
658−-- >>> type ImageUrl = T.Text
659−-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
660−-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
661−--
662−-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
663−-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
664−toSchemaBoundedEnumKeyMapping :: forall map key value.
665− (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
666− => Proxy (map key value) -> Schema
667−toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping
668
582
669-- | A configurable generic @'Schema'@ creator.
583-- | A configurable generic @'Schema'@ creator.
670−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
584+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema
672−genericDeclareSchema = genericDeclareSchemaUnrestricted
585+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy
673
586
674-- | A configurable generic @'NamedSchema'@ creator.
587-- | A configurable generic @'NamedSchema'@ creator.
675-- This function applied to @'defaultSchemaOptions'@
588-- This function applied to @'defaultSchemaOptions'@
676-- is used as the default for @'declareNamedSchema'@
589-- is used as the default for @'declareNamedSchema'@
677-- when the type is an instance of @'Generic'@.
590-- when the type is an instance of @'Generic'@.
678−genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
679− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
680−genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted
681−
682−-- | A configurable generic @'Schema'@ creator.
683−--
684−-- Unlike 'genericDeclareSchema' also works for mixed sum types.
685−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
686−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
687−genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy
688−
689−-- | A configurable generic @'NamedSchema'@ creator.
690−--
691−-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
692−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
693−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
694− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
591+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema
695−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
592+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty
696−
697−-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
698−genericNameSchema :: forall a d f.
699− (Generic a, Rep a ~ D1 d f, Datatype d)
700− => SchemaOptions -> Proxy a -> Schema -> NamedSchema
701−genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
702
593
703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
594+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
704−gdatatypeSchemaName opts _ = case orig of
595+gdatatypeSchemaName opts _ = case name of
705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
596 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
706 _ -> Nothing
597 _ -> Nothing
707 where
598 where
708− orig = datatypeName (Proxy3 :: Proxy3 d f a)
599+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
709− name = datatypeNameModifier opts orig
710
600
711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
601-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
602+paramSchemaToNamedSchema :: forall a d f proxy.
712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
603+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)
713− SchemaOptions -> Proxy a -> NamedSchema
604+ => SchemaOptions -> proxy a -> NamedSchema
714−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)
605+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)
715
606
716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
607-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
608+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema
718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy
609+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)
719
610
720nullarySchema :: Schema
611nullarySchema :: Schema
721nullarySchema = mempty
612nullarySchema = mempty
722− & type_ ?~ SwaggerArray
613+ & type_ .~ SwaggerArray
723 & items ?~ SwaggerItemsArray []
614 & items ?~ SwaggerItemsArray []
724
615
725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
616+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema
726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
617gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty
727
618
728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
619+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema
729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
620gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty
730
621
731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
622instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
@@ -745,7 +636,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where
745 gdeclareNamedSchema = gdeclareNamedSumSchema
636 gdeclareNamedSchema = gdeclareNamedSumSchema
746
637
747-- | Single field constructor.
638-- | Single field constructor.
748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
639+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where
749 gdeclareNamedSchema opts _ s
640 gdeclareNamedSchema opts _ s
750 | unwrapUnaryRecords opts = fieldSchema
641 | unwrapUnaryRecords opts = fieldSchema
751 | otherwise =
642 | otherwise =
@@ -759,7 +650,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s
759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
650 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
651 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s
761
652
762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
653+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)
763gdeclareSchemaRef opts proxy = do
654gdeclareSchemaRef opts proxy = do
764 case gtoNamedSchema opts proxy of
655 case gtoNamedSchema opts proxy of
765 NamedSchema (Just name) schema -> do
656 NamedSchema (Just name) schema -> do
@@ -790,12 +681,12 @@ withFieldSchema opts _ isRequiredField schema = do
790 return $
681 return $
791 if T.null fname
682 if T.null fname
792 then schema
683 then schema
793− & type_ ?~ SwaggerArray
684+ & type_ .~ SwaggerArray
794 & items %~ appendItem ref
685 & items %~ appendItem ref
795 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
686 & maxItems %~ Just . maybe 1 (+1) -- increment maxItems
796 & minItems %~ Just . maybe 1 (+1) -- increment minItems
687 & minItems %~ Just . maybe 1 (+1) -- increment minItems
797 else schema
688 else schema
798− & type_ ?~ SwaggerObject
689+ & type_ .~ SwaggerObject
799 & properties . at fname ?~ ref
690 & properties . at fname ?~ ref
800 & if isRequiredField
691 & if isRequiredField
801 then required %~ (++ [fname])
692 then required %~ (++ [fname])
@@ -817,13 +708,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where
817instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
708instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where
818 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
709 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)
819
710
820−instance ( GSumToSchema f
711+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where
821− , GSumToSchema g
822− ) => GToSchema (f :+: g)
823− where
824 gdeclareNamedSchema = gdeclareNamedSumSchema
712 gdeclareNamedSchema = gdeclareNamedSumSchema
825
713
826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
714+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
827gdeclareNamedSumSchema opts proxy s
715gdeclareNamedSumSchema opts proxy s
828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
716 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
717 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
@@ -832,29 +720,29 @@ gdeclareNamedSumSchema opts proxy s
832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
720 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)
833
721
834 toStringTag schema = mempty
722 toStringTag schema = mempty
835− & type_ ?~ SwaggerString
723+ & type_ .~ SwaggerString
836 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
724 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)
837
725
838type AllNullary = All
726type AllNullary = All
839
727
840class GSumToSchema (f :: * -> *) where
728class GSumToSchema (f :: * -> *) where
841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
729+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema
842
730
843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
731instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
844 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
732 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)
845
733
846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
734+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
735+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema
848gsumConToSchemaWith ref opts _ schema = schema
736gsumConToSchemaWith ref opts _ schema = schema
849− & type_ ?~ SwaggerObject
737+ & type_ .~ SwaggerObject
850 & properties . at tag ?~ ref
738 & properties . at tag ?~ ref
851 & maxProperties ?~ 1
739 & maxProperties ?~ 1
852 & minProperties ?~ 1
740 & minProperties ?~ 1
853 where
741 where
854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
742 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))
855
743
856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
744+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>
857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
745+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
858gsumConToSchema opts proxy schema = do
746gsumConToSchema opts proxy schema = do
859 ref <- gdeclareSchemaRef opts proxy
747 ref <- gdeclareSchemaRef opts proxy
860 return $ gsumConToSchemaWith ref opts proxy schema
748 return $ gsumConToSchemaWith ref opts proxy schema
@@ -878,5 +766,3 @@ data Proxy3 a b c = Proxy3
878
766
879-- $setup
767-- $setup
880-- >>> import Data.Swagger
768-- >>> import Data.Swagger
881−-- >>> import Data.Aeson (encode)
882−-- >>> import Data.Aeson.Types (toJSONKeyText)
src/Data/Swagger/Internal/Schema/Validation.hs+56−242
@@ -1,17 +1,15 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE DeriveFunctor #-}
1+{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE FunctionalDependencies #-}
3+{-# LANGUAGE FunctionalDependencies #-}
6−{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE PackageImports #-}
8+{-# LANGUAGE PackageImports #-}
11−{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE UndecidableInstances #-}
15-- |
13-- |
16-- Module: Data.Swagger.Internal.Schema.Validation
14-- Module: Data.Swagger.Internal.Schema.Validation
17-- Copyright: (c) 2015 GetShopTV
15-- Copyright: (c) 2015 GetShopTV
@@ -22,34 +20,28 @@
22-- Validate JSON values with Swagger Schema.
20-- Validate JSON values with Swagger Schema.
23module Data.Swagger.Internal.Schema.Validation where
21module Data.Swagger.Internal.Schema.Validation where
24
22
25−import Prelude ()
23+import Control.Applicative
26−import Prelude.Compat
24+import Control.Lens
25+import Control.Monad (when)
27
26
28−import Control.Applicative
29−import Control.Lens
30−import Control.Monad (when)
31−
32−import Data.Aeson hiding (Result)
27+import Data.Aeson hiding (Result)
33−import Data.Aeson.Encode.Pretty (encodePretty)
34−import Data.Foldable (for_, sequenceA_,
28+import Data.Foldable (traverse_, for_, sequenceA_)
35− traverse_)
36−import Data.HashMap.Strict (HashMap)
29+import Data.HashMap.Strict (HashMap)
37−import qualified Data.HashMap.Strict as HashMap
30+import qualified Data.HashMap.Strict as HashMap
38−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
39import qualified "unordered-containers" Data.HashSet as HashSet
31import qualified "unordered-containers" Data.HashSet as HashSet
32+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
33+import Data.Monoid
40−import Data.Proxy
34+import Data.Proxy
41−import Data.Scientific (Scientific, isInteger)
35+import Data.Scientific (Scientific, isInteger)
42−import Data.Text (Text)
36+import Data.Text (Text)
43−import qualified Data.Text as Text
37+import qualified Data.Text as Text
44−import qualified Data.Text.Lazy as TL
38+import Data.Vector (Vector)
45−import qualified Data.Text.Lazy.Encoding as TL
46−import Data.Vector (Vector)
47−import qualified Data.Vector as Vector
39+import qualified Data.Vector as Vector
48−
40+
49−import Data.Swagger.Declare
41+import Data.Swagger.Declare
50−import Data.Swagger.Internal
42+import Data.Swagger.Internal
51−import Data.Swagger.Internal.Schema
43+import Data.Swagger.Internal.Schema
52−import Data.Swagger.Lens
44+import Data.Swagger.Lens
53
45
54-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
46-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.
55-- This can be used with QuickCheck to ensure those instances are coherent:
47-- This can be used with QuickCheck to ensure those instances are coherent:
@@ -58,119 +50,22 @@ import Data.Swagger.Lens
58--
50--
59-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
51-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
60-- See @'validateToJSONWithPatternChecker'@.
52-- 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.
67validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
53validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
68validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
54validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
69
55
70-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
56-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
71-- This can be used with QuickCheck to ensure those instances are coherent.
57-- This can be used with QuickCheck to ensure those instances are coherent.
72--
58--
73−-- For validation without patterns see @'validateToJSON'@. See also:
59+-- For validation without patterns see @'validateToJSON'@.
74−-- 'renderValidationErrors'.
75−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
60+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>
61+ (Pattern -> Text -> Bool) -> a -> [ValidationError]
76−validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
62+validateToJSONWithPatternChecker checker x =
77− where
78− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
79−
80−-- | Pretty print validation errors
81−-- together with actual JSON and Swagger Schema
82−-- (using 'encodePretty').
83−--
84−-- >>> import Data.Aeson as Aeson
85−-- >>> import Data.Foldable (traverse_)
86−-- >>> import GHC.Generics
87−-- >>> data Phone = Phone { value :: String } deriving (Generic)
88−-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)
89−-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]
90−-- >>> instance ToSchema Phone
91−-- >>> instance ToSchema Person
92−-- >>> let person = Person { name = "John", phone = Phone "123456" }
93−-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person
94−-- Validation against the schema fails:
95−-- * property "phone" is required, but not found in "{\"name\":\"John\"}"
96−-- <BLANKLINE>
97−-- JSON value:
98−-- {
99−-- "name": "John"
100−-- }
101−-- <BLANKLINE>
102−-- Swagger Schema:
103−-- {
104−-- "required": [
105−-- "name",
106−-- "phone"
107−-- ],
108−-- "type": "object",
109−-- "properties": {
110−-- "phone": {
111−-- "$ref": "#/definitions/Phone"
112−-- },
113−-- "name": {
114−-- "type": "string"
115−-- }
116−-- }
117−-- }
118−-- <BLANKLINE>
119−-- Swagger Description Context:
120−-- {
121−-- "Phone": {
122−-- "required": [
123−-- "value"
124−-- ],
125−-- "type": "object",
126−-- "properties": {
127−-- "value": {
128−-- "type": "string"
129−-- }
130−-- }
131−-- }
132−-- }
133−-- <BLANKLINE>
134−renderValidationErrors
135− :: forall a. (ToJSON a, ToSchema a)
136− => (a -> [ValidationError]) -> a -> Maybe String
137−renderValidationErrors f x =
138− case f x of
139− [] -> Nothing
140− errors -> Just $ unlines
141− [ "Validation against the schema fails:"
142− , unlines (map (" * " ++) errors)
143− , "JSON value:"
144− , ppJSONString (toJSON x)
145− , ""
146− , "Swagger Schema:"
147− , ppJSONString (toJSON schema_)
148− , ""
149− , "Swagger Description Context:"
150− , ppJSONString (toJSON refs_)
151− ]
152− where
153− ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty
154− (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
155−
156−-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
157−--
158−-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
159−--
160−-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.
161−-- See @'validateJSONWithPatternChecker'@.
162−validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]
163−validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)
164−
165−-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.
166−--
167−-- For validation without patterns see @'validateJSON'@.
168−validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]
169−validateJSONWithPatternChecker checker defs sch js =
170 case runValidation (validateWithSchema js) cfg sch of
63 case runValidation (validateWithSchema js) cfg sch of
171 Failed xs -> xs
64 Failed xs -> xs
172 Passed _ -> mempty
65 Passed _ -> mempty
173 where
66 where
67+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
68+ js = toJSON x
174 cfg = defaultConfig
69 cfg = defaultConfig
175 { configPatternChecker = checker
70 { configPatternChecker = checker
176 , configDefinitions = defs }
71 , configDefinitions = defs }
@@ -263,18 +158,12 @@ valid = pure ()
263
158
264-- | Validate schema's property given a lens into that property
159-- | Validate schema's property given a lens into that property
265-- and property checker.
160-- and property checker.
266−checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
161+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
267−checkMissing missing l g = withSchema $ \sch ->
162+check l g = withSchema $ \sch ->
268 case sch ^. l of
163 case sch ^. l of
269− Nothing -> missing
164+ Nothing -> valid
270 Just x -> g x
165 Just x -> g x
271
166
272−-- | Validate schema's property given a lens into that property
273−-- and property checker.
274−-- If property is missing in schema, consider it valid.
275−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
276−check = checkMissing valid
277−
278-- | Validate same value with different schema.
167-- | Validate same value with different schema.
279sub :: t -> Validation t a -> Validation s a
168sub :: t -> Validation t a -> Validation s a
280sub = lmap . const
169sub = lmap . const
@@ -403,109 +292,34 @@ validateObject o = withSchema $ \sch ->
403 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
292 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property
404 _ ->
293 _ ->
405 case InsOrdHashMap.lookup k (sch ^. properties) of
294 case InsOrdHashMap.lookup k (sch ^. properties) of
406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v
295+ Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v
407 Just s -> validateWithSchemaRef s v
296 Just s -> validateWithSchemaRef s v
408
297
409− validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid
410− validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"
411− validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v
412−
413− unknownProperty :: Text -> Validation s a
414− unknownProperty pname = invalid $
415− "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"
416−
417validateEnum :: Value -> Validation (ParamSchema t) ()
298validateEnum :: Value -> Validation (ParamSchema t) ()
418validateEnum value = do
299validateEnum value = do
419 check enum_ $ \xs ->
300 check enum_ $ \xs ->
420 when (value `notElem` xs) $
301 when (value `notElem` xs) $
421 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
302 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
422
303
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−
470validateSchemaType :: Value -> Validation Schema ()
304validateSchemaType :: Value -> Validation Schema ()
471validateSchemaType value = withSchema $ \sch ->
305validateSchemaType value = withSchema $ \sch ->
472 case (sch ^. type_, value) of
306 case (sch ^. type_, value) of
473− (Just SwaggerNull, Null) -> valid
307+ (SwaggerNull, Null) -> valid
474− (Just SwaggerBoolean, Bool _) -> valid
308+ (SwaggerBoolean, Bool _) -> valid
475− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
309+ (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
476− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
310+ (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
477− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
311+ (SwaggerString, String s) -> sub_ paramSchema (validateString s)
478− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
312+ (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
479− (Just SwaggerObject, Object o) -> validateObject o
313+ (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
314+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
488
315
489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
316validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
490validateParamSchemaType value = withSchema $ \sch ->
317validateParamSchemaType value = withSchema $ \sch ->
491 case (sch ^. type_, value) of
318 case (sch ^. type_, value) of
492− (Just SwaggerBoolean, Bool _) -> valid
319+ (SwaggerBoolean, Bool _) -> valid
493− (Just SwaggerInteger, Number n) -> validateInteger n
320+ (SwaggerInteger, Number n) -> validateInteger n
494− (Just SwaggerNumber, Number n) -> validateNumber n
321+ (SwaggerNumber, Number n) -> validateNumber n
495− (Just SwaggerString, String s) -> validateString s
322+ (SwaggerString, String s) -> validateString s
496− (Just SwaggerArray, Array xs) -> validateArray xs
323+ (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
324+ (t, _) -> invalid $ "expected JSON value of type " ++ show t
503−
325+
504−showType :: (Maybe (SwaggerType t), Value) -> String
505−showType (Just type_, _) = show type_
506−showType (Nothing, Null) = "SwaggerNull"
507−showType (Nothing, Bool _) = "SwaggerBoolean"
508−showType (Nothing, Number _) = "SwaggerNumber"
509−showType (Nothing, String _) = "SwaggerString"
510−showType (Nothing, Array _) = "SwaggerArray"
511−showType (Nothing, Object _) = "SwaggerObject"
src/Data/Swagger/Internal/TypeShape.hsdeleted−66
@@ -1,66 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE KindSignatures #-}
5−{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE TypeOperators #-}
7−{-# LANGUAGE UndecidableInstances #-}
8−
9−module Data.Swagger.Internal.TypeShape where
10−
11−import Data.Proxy
12−import GHC.Generics
13−import GHC.TypeLits
14−import GHC.Exts (Constraint)
15−
16−-- | Shape of a datatype.
17−data TypeShape
18− = Enumeration -- ^ A simple enumeration.
19− | SumOfProducts -- ^ A product or a sum of non-unit products.
20− | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.
21−
22−-- | A combined shape for a product type.
23−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
24− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products
25− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products
26− ProdCombine a b = SumOfProducts
27−
28−-- | A combined shape for a sum type.
29−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where
30− SumCombine Enumeration Enumeration = Enumeration
31− SumCombine SumOfProducts SumOfProducts = SumOfProducts
32− SumCombine a b = Mixed
33−
34−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where
35− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))
36−
37−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where
38− GenericHasSimpleShape t f Enumeration = ()
39− GenericHasSimpleShape t f SumOfProducts = ()
40−#if __GLASGOW_HASKELL__ < 800
41− GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t
42−
43−class CannotDeriveSchemaForMixedSumType t where
44−#else
45− GenericHasSimpleShape t f Mixed =
46− TypeError
47− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t
48− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."
49− :$$: Text "Swagger does not have a good representation for these types."
50− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"
51− :$$: Text "that matches aeson's Generic-based toJSON,"
52− :$$: Text "but that's not supported by some Swagger tools."
53− )
54−#endif
55−
56−-- | Infer a 'TypeShape' for a generic representation of a type.
57−type family GenericShape (g :: * -> *) :: TypeShape
58−
59−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)
60−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)
61−type instance GenericShape (D1 d f) = GenericShape f
62−type instance GenericShape (C1 c U1) = Enumeration
63−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts
64−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts
65−
66−
src/Data/Swagger/Internal/Utils.hs+1
@@ -21,6 +21,7 @@ import qualified Data.HashMap.Strict as HashMap
21import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
21import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
22import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
22import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
23import Data.Map (Map)
23import Data.Map (Map)
24+import Data.Monoid
24import Data.Set (Set)
25import Data.Set (Set)
25import Data.Text (Text)
26import Data.Text (Text)
26import GHC.Generics
27import GHC.Generics
src/Data/Swagger/Lens.hs+4−10
@@ -96,19 +96,13 @@ instance At Responses where at n = responses . at n
96instance Ixed Operation where ix n = responses . ix n
96instance Ixed Operation where ix n = responses . ix n
97instance At Operation where at n = responses . at n
97instance At Operation where at n = responses . at n
98
98
99−type instance Index SecurityDefinitions = Text
100−type instance IxValue SecurityDefinitions = SecurityScheme
101−
102−instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n
103−instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n
104−
105instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
99instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
106
100
107-- HasType instances
101-- HasType instances
108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_
102+instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_
109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
103+instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_
110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_
104+instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_
111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_
105+instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_
112
106
113-- HasDefault instances
107-- HasDefault instances
114instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
108instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_
src/Data/Swagger/Operation.hs+5−5
@@ -37,7 +37,7 @@ import Control.Lens
37import Data.Data.Lens
37import Data.Data.Lens
38import Data.List.Compat
38import Data.List.Compat
39import Data.Maybe (mapMaybe)
39import Data.Maybe (mapMaybe)
40−import Data.Proxy
40+import Data.Monoid
41import qualified Data.Set as Set
41import qualified Data.Set as Set
42
42
43import Data.Swagger.Declare
43import Data.Swagger.Declare
@@ -46,7 +46,6 @@ import Data.Swagger.Lens
46import Data.Swagger.Schema
46import Data.Swagger.Schema
47
47
48import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
48import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49−import qualified Data.HashSet.InsOrd as InsOrdHS
50
49
51-- $setup
50-- $setup
52-- >>> import Data.Aeson
51-- >>> import Data.Aeson
@@ -112,15 +111,15 @@ applyTags = applyTagsFor allOperations
112-- list of tags.
111-- list of tags.
113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
112applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
114applyTagsFor ops ts swag = swag
113applyTagsFor ops ts swag = swag
115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
114+ & ops . tags %~ (<> Set.fromList (map _tagName ts))
116− & tags %~ (<> InsOrdHS.fromList ts)
115+ & tags %~ (<> Set.fromList ts)
117
116
118-- | Construct a response with @'Schema'@ while declaring all
117-- | Construct a response with @'Schema'@ while declaring all
119-- necessary schema definitions.
118-- necessary schema definitions.
120--
119--
121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
120-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
122-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
121-- "[{\"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
124declareResponse proxy = do
123declareResponse proxy = do
125 s <- declareSchemaRef proxy
124 s <- declareSchemaRef proxy
126 return (mempty & schema ?~ s)
125 return (mempty & schema ?~ s)
@@ -191,3 +190,4 @@ setResponseForWith ops f code dres swag = swag
191 Nothing -> new -- response name can't be dereferenced, replacing with new response
190 Nothing -> new -- response name can't be dereferenced, replacing with new response
192 combine (Just (Inline old)) = f old new
191 combine (Just (Inline old)) = f old new
193 combine Nothing = new
192 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−15
@@ -17,25 +17,11 @@ module Data.Swagger.Schema (
17 -- * Generic schema encoding
17 -- * Generic schema encoding
18 genericDeclareNamedSchema,
18 genericDeclareNamedSchema,
19 genericDeclareSchema,
19 genericDeclareSchema,
20− genericDeclareNamedSchemaNewtype,
21− genericNameSchema,
22−
23− -- ** 'Bounded' 'Integral'
24 genericToNamedSchemaBoundedIntegral,
20 genericToNamedSchemaBoundedIntegral,
25 toSchemaBoundedIntegral,
21 toSchemaBoundedIntegral,
26−
27− -- ** 'Bounded' 'Enum' key mappings
28− declareSchemaBoundedEnumKeyMapping,
29− toSchemaBoundedEnumKeyMapping,
30−
31− -- ** Reusing 'ToParamSchema'
32 paramSchemaToNamedSchema,
22 paramSchemaToNamedSchema,
33 paramSchemaToSchema,
23 paramSchemaToSchema,
34
24
35− -- ** Unrestricted versions
36− genericDeclareNamedSchemaUnrestricted,
37− genericDeclareSchemaUnrestricted,
38−
39 -- * Schema templates
25 -- * Schema templates
40 passwordSchema,
26 passwordSchema,
41 binarySchema,
27 binarySchema,
@@ -54,7 +40,6 @@ module Data.Swagger.Schema (
54 -- * Generic encoding configuration
40 -- * Generic encoding configuration
55 SchemaOptions(..),
41 SchemaOptions(..),
56 defaultSchemaOptions,
42 defaultSchemaOptions,
57− fromAesonOptions,
58) where
43) where
59
44
60import Data.Swagger.Internal.Schema
45import Data.Swagger.Internal.Schema
src/Data/Swagger/Schema/Generator.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE OverloadedLists #-}
3−{-# LANGUAGE ScopedTypeVariables #-}
4−
5−module Data.Swagger.Schema.Generator where
6−
7−import Prelude ()
8−import Prelude.Compat
9−
10−import Control.Lens.Operators
11−import Control.Monad (filterM)
12−import Data.Aeson
13−import Data.Aeson.Types
14−import qualified Data.HashMap.Strict.InsOrd as M
15−import Data.Maybe
16−import Data.Maybe
17−import Data.Proxy
18−import Data.Scientific
19−import qualified Data.Set as S
20−import Data.Swagger
21−import Data.Swagger.Declare
22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)
23−import qualified Data.Text as T
24−import qualified Data.Vector as V
25−import Test.QuickCheck (arbitrary)
26−import Test.QuickCheck.Gen
27−import Test.QuickCheck.Property
28−
29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30−-- and cannot be inferred.
31−schemaGen :: Definitions Schema -> Schema -> Gen Value
32−schemaGen _ schema
33− | Just cases <- schema ^. paramSchema . enum_ = elements cases
34−schemaGen defns schema =
35− case schema ^. type_ of
36− Nothing ->
37− case inferSchemaTypes schema of
38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
39− -- Gen is not MonadFail
40− _ -> error "unable to infer schema type"
41− Just SwaggerBoolean -> Bool <$> elements [True, False]
42− Just SwaggerNull -> pure Null
43− Just SwaggerNumber
44− | Just min <- schema ^. minimum_
45− , Just max <- schema ^. maximum_ ->
46− Number . fromFloatDigits <$>
47− choose (toRealFloat min, toRealFloat max :: Double)
48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)
49− Just SwaggerInteger
50− | Just min <- schema ^. minimum_
51− , Just max <- schema ^. maximum_ ->
52− Number . fromInteger <$>
53− choose (truncate min, truncate max)
54− | otherwise -> Number . fromInteger <$> arbitrary
55− Just SwaggerArray
56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty
57− | Just items <- schema ^. items ->
58− case items of
59− SwaggerItemsObject ref -> do
60− size <- getSize
61− let itemSchema = dereference defns ref
62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems
63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems
64− arrayLength <- choose (minLength', max minLength' maxLength')
65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema
66− return . Array $ V.fromList generatedArray
67− SwaggerItemsArray refs ->
68− let itemGens = schemaGen defns . dereference defns <$> refs
69− in fmap (Array . V.fromList) $ sequence itemGens
70− Just SwaggerString -> do
71− size <- getSize
72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength
73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength
74− length <- choose (minLength', max minLength' maxLength')
75− str <- vectorOf length arbitrary
76− return . String $ T.pack str
77− Just SwaggerObject -> do
78− size <- getSize
79− let props = dereference defns <$> schema ^. properties
80− reqKeys = S.fromList $ schema ^. required
81− allKeys = S.fromList . M.keys $ schema ^. properties
82− optionalKeys = allKeys S.\\ reqKeys
83− minProps' = fromMaybe (length reqKeys) $
84− fromInteger <$> schema ^. minProperties
85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties
86− shuffledOptional <- shuffle $ S.toList optionalKeys
87− numProps <- choose (minProps', max minProps' maxProps')
88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional
89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props
90− let gens = schemaGen defns <$> presentProps
91− additionalGens <- case schema ^. additionalProperties of
92− Just (AdditionalPropertiesSchema addlSchema) -> do
93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary
94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)
95− _ -> return []
96− x <- sequence $ gens <> additionalGens
97− return . Object $ M.toHashMap x
98− where
99− dereference :: Definitions a -> Referenced a -> a
100− dereference _ (Inline a) = a
101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs
102−
103−genValue :: (ToSchema a) => Proxy a -> Gen Value
104−genValue p =
105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty
106− in schemaGen defs schema
107−
108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property
109−validateFromJSON p = forAll (genValue p) $
110− \val -> case parseEither parseJSON val of
111− Right (_ :: a) -> succeeded
112− Left err -> failed
113− { reason = err
114− }
src/Data/Swagger/Schema/Validation.hs+1−10
@@ -15,18 +15,9 @@ module Data.Swagger.Schema.Validation (
15 -- $maybe
15 -- $maybe
16
16
17 -- * JSON validation
17 -- * JSON validation
18−
19− ValidationError,
20−
21− -- ** Using 'ToJSON' and 'ToSchema'
22− validatePrettyToJSON,
23 validateToJSON,
18 validateToJSON,
24 validateToJSONWithPatternChecker,
19 validateToJSONWithPatternChecker,
25− renderValidationErrors,
20+ ValidationError,
26−
27− -- ** Using 'Value' and 'Schema'
28− validateJSON,
29− validateJSONWithPatternChecker,
30) where
21) where
31
22
32import Data.Swagger.Internal.Schema.Validation
23import Data.Swagger.Internal.Schema.Validation
src/Data/Swagger/SchemaOptions.hs−29
@@ -1,4 +1,3 @@
1−{-# LANGUAGE RecordWildCards #-}
2-- |
1-- |
3-- Module: Data.Swagger.SchemaOptions
2-- Module: Data.Swagger.SchemaOptions
4-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
@@ -7,8 +6,6 @@
7-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
6-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
8module Data.Swagger.SchemaOptions where
7module Data.Swagger.SchemaOptions where
9
8
10−import qualified Data.Aeson.Types as Aeson
11−
12-- | Options that specify how to encode your type to Swagger schema.
9-- | Options that specify how to encode your type to Swagger schema.
13data SchemaOptions = SchemaOptions
10data SchemaOptions = SchemaOptions
14 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
11 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
@@ -44,29 +41,3 @@ defaultSchemaOptions = SchemaOptions
44 , unwrapUnaryRecords = False
41 , unwrapUnaryRecords = False
45 }
42 }
46
43
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+1−7
@@ -1,9 +1,3 @@
1−resolver: lts-14.3
1+resolver: lts-8.0
2packages:
2packages:
3- '.'
3- '.'
4−extra-deps:
5−- optics-core-0.2
6−- optics-th-0.2
7−- optics-extra-0.2
8−- indexed-profunctors-0.1
9−- insert-ordered-containers-0.2.3
swagger2.cabal+48−85
@@ -1,15 +1,11 @@
1−cabal-version: >=1.10
2name: swagger2
1name: swagger2
3−version: 2.5
2+version: 2.1.4.1
4−
5synopsis: Swagger 2.0 data model
3synopsis: Swagger 2.0 data model
6−category: Web, Swagger
7description:
4description:
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
9 specifications as well as manipulating them.
6 specifications as well as manipulating them.
10 .
7 .
11 The original Swagger 2.0 specification is available at http://swagger.io/specification/.
8 The original Swagger 2.0 specification is available at http://swagger.io/specification/.
12−
13homepage: https://github.com/GetShopTV/swagger2
9homepage: https://github.com/GetShopTV/swagger2
14bug-reports: https://github.com/GetShopTV/swagger2/issues
10bug-reports: https://github.com/GetShopTV/swagger2/issues
15license: BSD3
11license: BSD3
@@ -17,22 +13,19 @@ license-file: LICENSE
17author: Nickolay Kudasov
13author: Nickolay Kudasov
18maintainer: nickolay@getshoptv.com
14maintainer: nickolay@getshoptv.com
19copyright: (c) 2015-2016, GetShopTV
15copyright: (c) 2015-2016, GetShopTV
16+category: Web, Swagger
20build-type: Custom
17build-type: Custom
21extra-source-files:
18extra-source-files:
22 README.md
19 README.md
23 , CHANGELOG.md
20 , CHANGELOG.md
24 , examples/*.hs
21 , examples/*.hs
25 , include/overlapping-compat.h
22 , include/overlapping-compat.h
23+cabal-version: >=1.10
26−tested-with:
24+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1
27− GHC ==8.0.2
28− || ==8.2.2
29− || ==8.4.4
30− || ==8.6.5
31− || ==8.8.1
32
25
33custom-setup
26custom-setup
34 setup-depends:
27 setup-depends:
35− base, Cabal, cabal-doctest >=1.0.6 && <1.1
28+ base, Cabal, cabal-doctest >=1.0.2 && <1.1
36
29
37library
30library
38 hs-source-dirs: src
31 hs-source-dirs: src
@@ -42,10 +35,8 @@ library
42 Data.Swagger.Declare
35 Data.Swagger.Declare
43 Data.Swagger.Lens
36 Data.Swagger.Lens
44 Data.Swagger.Operation
37 Data.Swagger.Operation
45− Data.Swagger.Optics
46 Data.Swagger.ParamSchema
38 Data.Swagger.ParamSchema
47 Data.Swagger.Schema
39 Data.Swagger.Schema
48− Data.Swagger.Schema.Generator
49 Data.Swagger.Schema.Validation
40 Data.Swagger.Schema.Validation
50 Data.Swagger.SchemaOptions
41 Data.Swagger.SchemaOptions
51
42
@@ -56,90 +47,62 @@ library
56 Data.Swagger.Internal.ParamSchema
47 Data.Swagger.Internal.ParamSchema
57 Data.Swagger.Internal.Utils
48 Data.Swagger.Internal.Utils
58 Data.Swagger.Internal.AesonUtils
49 Data.Swagger.Internal.AesonUtils
59− Data.Swagger.Internal.TypeShape
60−
61− -- GHC boot libraries
62− build-depends:
50+ build-depends: base >=4.7 && <4.11
63− base >=4.9 && <4.14
51+ , base-compat >=0.9.1 && <0.10
64− , aeson-pretty >=0.8.7 && <0.9
52+ , aeson >=0.11.2.1
65− , bytestring >=0.10.4.0 && <0.11
53+ , bytestring
66− , containers >=0.5.5.1 && <0.7
54+ , containers
67− , template-haskell >=2.9.0.0 && <2.16
55+ , hashable
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
56+ , generics-sop >=0.2 && <0.4
82− , hashable >=1.2.7.0 && <1.4
83− , http-media >=0.7.1.2 && <0.9
57+ , http-media
84− , insert-ordered-containers >=0.2.3 && <0.3
58+ , insert-ordered-containers >=0.1.0.0 && <0.3
85− , lens >=4.16.1 && <4.19
59+ , lens
60+ , mtl
86− , network >=2.6.3.5 && <3.2
61+ , network
87− , optics-core >=0.2 && <0.3
88− , optics-th >=0.2 && <0.3
89− , scientific >=0.3.6.2 && <0.4
62+ , scientific
63+ , text
64+ , template-haskell
65+ , time
66+ , transformers
90− , transformers-compat >=0.3 && <0.7
67+ , transformers-compat >= 0.3
91− , unordered-containers >=0.2.9.0 && <0.3
68+ , unordered-containers
69+ , vector
92− , uuid-types >=1.0.3 && <1.1
70+ , uuid-types >=1.0.2 && <1.1
93− , vector >=0.12.0.1 && <0.13
94− , QuickCheck >=2.10.1 && <2.14
95−
96 default-language: Haskell2010
71 default-language: Haskell2010
97
72
98test-suite spec
73test-suite spec
99 type: exitcode-stdio-1.0
74 type: exitcode-stdio-1.0
100 hs-source-dirs: test
75 hs-source-dirs: test
101 main-is: Spec.hs
76 main-is: Spec.hs
102−
103− -- From library parat
104 -- We need aeson's toEncoding for doctests too
77 -- We need aeson's toEncoding for doctests too
105− build-depends:
78+ build-depends: base
106− base
107− , swagger2
108− , aeson
109− , base-compat-batteries
79+ , base-compat
80+ , aeson >=0.10.0.0
81+ , aeson-qq
110− , bytestring
82+ , bytestring
111− , containers
83+ , containers
112− , hashable
84+ , hashable
85+ , hspec
113− , insert-ordered-containers
86+ , insert-ordered-containers
114− , lens
87+ , HUnit
115− , mtl
88+ , mtl
116− , template-haskell
89+ , QuickCheck >=2.8.2
90+ , swagger2
117− , text
91+ , text
118− , time
92+ , time
119− , unordered-containers
93+ , unordered-containers
120− , vector
94+ , vector
121− , QuickCheck
95+ , lens
122−
123− -- test-suite only dependencies
124− build-depends:
125− hspec >=2.5.5 && <2.8
126− , HUnit >=1.6.0.0 && <1.7
127− , quickcheck-instances >=0.3.19 && <0.14
128− , utf8-string >=1.0.1.1 && <1.1
129−
130− -- https://github.com/haskell/cabal/issues/3708
131− build-tool-depends:
132− hspec-discover:hspec-discover >=2.5.5 && <2.8
133−
134 other-modules:
96 other-modules:
135 SpecCommon
97 SpecCommon
136 Data.SwaggerSpec
98 Data.SwaggerSpec
137− Data.Swagger.CommonTestTypes
138 Data.Swagger.ParamSchemaSpec
99 Data.Swagger.ParamSchemaSpec
139 Data.Swagger.SchemaSpec
100 Data.Swagger.SchemaSpec
140 Data.Swagger.Schema.ValidationSpec
101 Data.Swagger.Schema.ValidationSpec
141− Data.Swagger.Schema.GeneratorSpec
142 default-language: Haskell2010
102 default-language: Haskell2010
103+ -- https://github.com/haskell/cabal/issues/3708
104+ build-tool-depends:
105+ hspec-discover:hspec-discover
143
106
144test-suite doctests
107test-suite doctests
145 -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes
108 -- 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+83−7
@@ -3,11 +3,10 @@
3{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE QuasiQuotes #-}
5{-# LANGUAGE QuasiQuotes #-}
6−{-# LANGUAGE OverloadedStrings #-}
7module Data.Swagger.ParamSchemaSpec where
6module Data.Swagger.ParamSchemaSpec where
8
7
9import Data.Aeson
8import Data.Aeson
10−import Data.Aeson.QQ.Simple
9+import Data.Aeson.QQ
11import Data.Char
10import Data.Char
12import Data.Proxy
11import Data.Proxy
13import GHC.Generics
12import GHC.Generics
@@ -15,12 +14,8 @@ import GHC.Generics
15import Data.Swagger
14import Data.Swagger
16import Data.Swagger.Internal (SwaggerKind(..))
15import Data.Swagger.Internal (SwaggerKind(..))
17
16
18−import Data.Swagger.CommonTestTypes
19import SpecCommon
17import SpecCommon
20import Test.Hspec
18import Test.Hspec
21−import Data.Time.LocalTime
22−
23−import qualified Data.HashMap.Strict as HM
24
19
25checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
20checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
26checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
21checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
@@ -34,7 +29,88 @@ spec = do
34 context "Unary records" $ do
29 context "Unary records" $ do
35 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
30 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
36 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
31 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
38
32
39main :: IO ()
33main :: IO ()
40main = hspec spec
34main = 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+49−132
@@ -1,50 +1,37 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE PackageImports #-}
3+{-# LANGUAGE PackageImports #-}
4−{-# LANGUAGE RecordWildCards #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
6{-# OPTIONS_GHC -fno-warn-orphans #-}
4{-# OPTIONS_GHC -fno-warn-orphans #-}
7module Data.Swagger.Schema.ValidationSpec where
5module Data.Swagger.Schema.ValidationSpec where
8
6
9−import Control.Applicative
7+import Control.Applicative
10−import Control.Lens ((&), (.~), (?~))
11−import Data.Aeson
8+import Data.Aeson
12−import Data.Aeson.Types
9+import Data.Aeson.Types
13−import Data.Hashable (Hashable)
10+import Data.Int
14−import Data.HashMap.Strict (HashMap)
11+import Data.IntMap (IntMap)
15−import qualified Data.HashMap.Strict as HashMap
12+import Data.Hashable (Hashable)
16−import "unordered-containers" Data.HashSet (HashSet)
13+import "unordered-containers" Data.HashSet (HashSet)
17import qualified "unordered-containers" Data.HashSet as HashSet
14import qualified "unordered-containers" Data.HashSet as HashSet
18−import Data.Int
15+import Data.HashMap.Strict (HashMap)
19−import Data.IntMap (IntMap)
16+import qualified Data.HashMap.Strict as HashMap
20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)
21−import Data.Map (Map, fromList)
17+import Data.Map (Map)
22−import Data.Monoid (mempty)
23−import Data.Proxy
18+import Data.Proxy
24−import Data.Set (Set)
19+import Data.Time
25−import qualified Data.Text as T
20+import qualified Data.Text as T
26−import qualified Data.Text.Lazy as TL
21+import qualified Data.Text.Lazy as TL
27−import Data.Time
22+import Data.Set (Set)
28−import Data.Version (Version)
29−import Data.Word
23+import Data.Word
30−import GHC.Generics
24+import GHC.Generics
31−
25+
32−import Data.Swagger
33−import Data.Swagger.Declare
26+import Data.Swagger
34−
27+
35−import Test.Hspec
28+import Test.Hspec
36−import Test.Hspec.QuickCheck
29+import Test.Hspec.QuickCheck
37−import Test.QuickCheck
38−import Test.QuickCheck.Instances ()
30+import Test.QuickCheck
39
31
40shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
32shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
41shouldValidate _ x = validateToJSON x == []
33shouldValidate _ x = validateToJSON x == []
42
34
43−shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
44−shouldNotValidate f = not . null . validateJSON defs sch . f
45− where
46− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
47−
48spec :: Spec
35spec :: Spec
49spec = do
36spec = do
50 describe "Validation" $ do
37 describe "Validation" $ do
@@ -73,7 +60,6 @@ spec = do
73 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
60 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
74 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
61 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
75 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
62 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
77 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
63 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
78 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
64 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
79 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
65 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
@@ -83,7 +69,6 @@ spec = do
83 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
69 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
84 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
70 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
85 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
71 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)
87 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
72 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
88 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
73 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
89 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
74 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
@@ -92,16 +77,6 @@ spec = do
92 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
77 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
93 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
78 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
94 prop "Light" $ shouldValidate (Proxy :: Proxy Light)
79 prop "Light" $ shouldValidate (Proxy :: Proxy Light)
95− prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
96− prop "Version" $ shouldValidate (Proxy :: Proxy Version)
97− prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
98−
99− describe "invalid cases" $ do
100− prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON
101− prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON
102− prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON
103− prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON
104− prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON
105
80
106main :: IO ()
81main :: IO ()
107main = hspec spec
82main = hspec spec
@@ -121,13 +96,6 @@ instance ToSchema Person
121instance Arbitrary Person where
96instance Arbitrary Person where
122 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
97 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
123
98
124−invalidPersonToJSON :: Person -> Value
125−invalidPersonToJSON Person{..} = object
126− [ T.pack "personName" .= toJSON name
127− , T.pack "personPhone" .= toJSON phone
128− , T.pack "personEmail" .= toJSON email
129− ]
130−
131-- ========================================================================
99-- ========================================================================
132-- Color (enum)
100-- Color (enum)
133-- ========================================================================
101-- ========================================================================
@@ -139,11 +107,6 @@ instance ToSchema Color
139instance Arbitrary Color where
107instance Arbitrary Color where
140 arbitrary = arbitraryBoundedEnum
108 arbitrary = arbitraryBoundedEnum
141
109
142−invalidColorToJSON :: Color -> Value
143−invalidColorToJSON Red = toJSON "red"
144−invalidColorToJSON Green = toJSON "green"
145−invalidColorToJSON Blue = toJSON "blue"
146−
147-- ========================================================================
110-- ========================================================================
148-- Paint (record with bounded enum property)
111-- Paint (record with bounded enum property)
149-- ========================================================================
112-- ========================================================================
@@ -157,9 +120,6 @@ instance ToSchema Paint
157instance Arbitrary Paint where
120instance Arbitrary Paint where
158 arbitrary = Paint <$> arbitrary
121 arbitrary = Paint <$> arbitrary
159
122
160−invalidPaintToJSON :: Paint -> Value
161−invalidPaintToJSON = toJSON . color
162−
163-- ========================================================================
123-- ========================================================================
164-- MyRoseTree (custom datatypeNameModifier)
124-- MyRoseTree (custom datatypeNameModifier)
165-- ========================================================================
125-- ========================================================================
@@ -188,8 +148,7 @@ instance Arbitrary MyRoseTree where
188
148
189data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
149data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
190
150
191−instance ToSchema Light where
151+instance ToSchema Light
192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
193
152
194instance ToJSON Light where
153instance ToJSON Light where
195 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
154 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
@@ -201,78 +160,36 @@ instance Arbitrary Light where
201 , LightColor <$> arbitrary
160 , LightColor <$> arbitrary
202 ]
161 ]
203
162
204−invalidLightToJSON :: Light -> Value
163+-- Arbitrary instances for common types
205−invalidLightToJSON = genericToJSON defaultOptions
206
164
207−-- ========================================================================
165+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where
208−-- ButtonImages (bounded enum key mapping)
166+ arbitrary = HashMap.fromList <$> arbitrary
209−-- ========================================================================
210
167
211−data ButtonState = Neutral | Focus | Active | Hover | Disabled
168+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where
212− deriving (Show, Eq, Ord, Bounded, Enum, Generic)
169+ arbitrary = HashSet.fromList <$> arbitrary
213−
214−instance ToJSON ButtonState
215−instance ToSchema ButtonState
216−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
217−
218−instance Arbitrary ButtonState where
219− arbitrary = arbitraryBoundedEnum
220−
221−type ImageUrl = T.Text
222−
223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
224− deriving (Show, Generic)
225
170
226−instance ToJSON ButtonImages where
171+instance Arbitrary T.Text where
227− toJSON = toJSON . getButtonImages
172+ arbitrary = T.pack <$> arbitrary
228
173
229−instance ToSchema ButtonImages where
174+instance Arbitrary TL.Text where
230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
175+ arbitrary = TL.pack <$> arbitrary
231− declareSchemaBoundedEnumKeyMapping
232
176
233−invalidButtonImagesToJSON :: ButtonImages -> Value
177+instance Arbitrary Day where
234−invalidButtonImagesToJSON = genericToJSON defaultOptions
178+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary
235
179
236−instance Arbitrary ButtonImages where
180+instance Arbitrary LocalTime where
181+ arbitrary = LocalTime
237− arbitrary = ButtonImages <$> arbitrary
182+ <$> arbitrary
238−
183+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))
239−-- ========================================================================
240−-- FreeForm (wraps a raw JSON Value)
241−-- ========================================================================
242−
243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
244− deriving (Show, Generic)
245−
246−instance ToJSON FreeForm where
247− toJSON = toJSON . jsonContent
248−
249−instance ToSchema FreeForm where
250− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
251− & type_ ?~ SwaggerObject
252− & additionalProperties ?~ AdditionalPropertiesAllowed True
253−
254−instance Arbitrary FreeForm where
255− arbitrary = (FreeForm . fromList) <$> genObj
256− where
257− genObj = listOf $ do
258− k <- arbitrary
259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
260− pure (k, v)
261
184
262instance Eq ZonedTime where
185instance Eq ZonedTime where
263 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
186 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
264
187
265−-- ========================================================================
188+instance Arbitrary ZonedTime where
266−-- Arbitrary instance for Data.Aeson.Value
189+ arbitrary = ZonedTime
267−-- ========================================================================
190+ <$> arbitrary
191+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))
192+
193+instance Arbitrary UTCTime where
194+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
268
195
269−instance Arbitrary Value where
270− -- Weights are almost random
271− -- Uniform oneof tends not to build complex objects cause of recursive call.
272− arbitrary = resize 4 $ frequency
273− [ (3, Object <$> arbitrary)
274− , (3, Array <$> arbitrary)
275− , (3, String <$> arbitrary)
276− , (3, Number <$> arbitrary)
277− , (3, Bool <$> arbitrary)
278− , (1, return Null) ]
test/Data/Swagger/SchemaSpec.hs+547−12
@@ -8,22 +8,21 @@ import Prelude ()
8import Prelude.Compat
8import Prelude.Compat
9
9
10import Control.Lens ((^.))
10import Control.Lens ((^.))
11−import Data.Aeson (Value)
11+import Data.Aeson
12+import Data.Aeson.QQ
13+import Data.Char
12import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
14import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
13import Data.Proxy
15import Data.Proxy
14import Data.Set (Set)
16import Data.Set (Set)
15import qualified Data.Text as Text
17import qualified Data.Text as Text
18+import GHC.Generics
16
19
17import Data.Swagger
20import Data.Swagger
18import Data.Swagger.Declare
21import Data.Swagger.Declare
19
22
20−import Data.Swagger.CommonTestTypes
21import SpecCommon
23import SpecCommon
22import Test.Hspec
24import Test.Hspec
23
25
24−import qualified Data.HashMap.Strict as HM
25−import Data.Time.LocalTime
26−
27checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
26checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
28checkToSchema proxy js = toSchema proxy <=> js
27checkToSchema proxy js = toSchema proxy <=> js
29
28
@@ -77,10 +76,8 @@ spec = do
77 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
76 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON
78 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
77 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON
79 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
78 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON
81 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
79 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
82 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
80 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
84 context "Sum types" $ do
81 context "Sum types" $ do
85 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
82 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
86 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
83 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -96,7 +93,6 @@ spec = do
96 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
93 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
97 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
94 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
98 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
95 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
100 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
96 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
101 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
97 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
102 describe "Inlining Schemas" $ do
98 describe "Inlining Schemas" $ do
@@ -105,10 +101,549 @@ spec = do
105 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
101 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
106 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
102 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
107 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
103 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
108− context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
109− describe "Bounded Enum key mapping" $ do
110− context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
111− context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON
112
104
113main :: IO ()
105main :: IO ()
114main = hspec spec
106main = hspec spec
107+
108+-- ========================================================================
109+-- Person (simple record with optional fields)
110+-- ========================================================================
111+data Person = Person
112+ { name :: String
113+ , phone :: Integer
114+ , email :: Maybe String
115+ } deriving (Generic)
116+
117+instance ToSchema Person
118+
119+personSchemaJSON :: Value
120+personSchemaJSON = [aesonQQ|
121+{
122+ "type": "object",
123+ "properties":
124+ {
125+ "name": { "type": "string" },
126+ "phone": { "type": "integer" },
127+ "email": { "type": "string" }
128+ },
129+ "required": ["name", "phone"]
130+}
131+|]
132+
133+-- ========================================================================
134+-- ISPair (non-record product data type)
135+-- ========================================================================
136+data ISPair = ISPair Integer String
137+ deriving (Generic)
138+
139+instance ToSchema ISPair
140+
141+ispairSchemaJSON :: Value
142+ispairSchemaJSON = [aesonQQ|
143+{
144+ "type": "array",
145+ "items":
146+ [
147+ { "type": "integer" },
148+ { "type": "string" }
149+ ],
150+ "minItems": 2,
151+ "maxItems": 2
152+}
153+|]
154+
155+-- ========================================================================
156+-- Point (record data type with custom fieldLabelModifier)
157+-- ========================================================================
158+
159+data Point = Point
160+ { pointX :: Double
161+ , pointY :: Double
162+ } deriving (Generic)
163+
164+instance ToSchema Point where
165+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
166+ { fieldLabelModifier = map toLower . drop (length "point") }
167+
168+pointSchemaJSON :: Value
169+pointSchemaJSON = [aesonQQ|
170+{
171+ "type": "object",
172+ "properties":
173+ {
174+ "x": { "type": "number", "format": "double" },
175+ "y": { "type": "number", "format": "double" }
176+ },
177+ "required": ["x", "y"]
178+}
179+|]
180+
181+-- ========================================================================
182+-- Point (record data type with multiple fields)
183+-- ========================================================================
184+
185+data Point5 = Point5
186+ { point5X :: Double
187+ , point5Y :: Double
188+ , point5Z :: Double
189+ , point5U :: Double
190+ , point5V :: Double -- 5 dimensional!
191+ } deriving (Generic)
192+
193+instance ToSchema Point5 where
194+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
195+ { fieldLabelModifier = map toLower . drop (length "point5") }
196+
197+point5SchemaJSON :: Value
198+point5SchemaJSON = [aesonQQ|
199+{
200+ "type": "object",
201+ "properties":
202+ {
203+ "x": { "type": "number", "format": "double" },
204+ "y": { "type": "number", "format": "double" },
205+ "z": { "type": "number", "format": "double" },
206+ "u": { "type": "number", "format": "double" },
207+ "v": { "type": "number", "format": "double" }
208+ },
209+ "required": ["x", "y", "z", "u", "v"]
210+}
211+|]
212+
213+point5Properties :: [String]
214+point5Properties = ["x", "y", "z", "u", "v"]
215+
216+-- ========================================================================
217+-- Color (enum)
218+-- ========================================================================
219+data Color
220+ = Red
221+ | Green
222+ | Blue
223+ deriving (Generic)
224+instance ToSchema Color
225+
226+colorSchemaJSON :: Value
227+colorSchemaJSON = [aesonQQ|
228+{
229+ "type": "string",
230+ "enum": ["Red", "Green", "Blue"]
231+}
232+|]
233+
234+-- ========================================================================
235+-- Shade (paramSchemaToNamedSchema)
236+-- ========================================================================
237+
238+data Shade = Dim | Bright deriving (Generic)
239+instance ToParamSchema Shade
240+
241+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions
242+
243+shadeSchemaJSON :: Value
244+shadeSchemaJSON = [aesonQQ|
245+{
246+ "type": "string",
247+ "enum": ["Dim", "Bright"]
248+}
249+|]
250+
251+-- ========================================================================
252+-- Paint (record with bounded enum property)
253+-- ========================================================================
254+
255+newtype Paint = Paint { color :: Color }
256+ deriving (Generic)
257+instance ToSchema Paint
258+
259+paintSchemaJSON :: Value
260+paintSchemaJSON = [aesonQQ|
261+{
262+ "type": "object",
263+ "properties":
264+ {
265+ "color":
266+ {
267+ "$ref": "#/definitions/Color"
268+ }
269+ },
270+ "required": ["color"]
271+}
272+|]
273+
274+paintInlinedSchemaJSON :: Value
275+paintInlinedSchemaJSON = [aesonQQ|
276+{
277+ "type": "object",
278+ "properties":
279+ {
280+ "color":
281+ {
282+ "type": "string",
283+ "enum": ["Red", "Green", "Blue"]
284+ }
285+ },
286+ "required": ["color"]
287+}
288+|]
289+
290+-- ========================================================================
291+-- Email (newtype with unwrapUnaryRecords set to True)
292+-- ========================================================================
293+
294+newtype Email = Email { getEmail :: String }
295+ deriving (Generic)
296+
297+instance ToSchema Email where
298+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
299+ { unwrapUnaryRecords = True }
300+
301+emailSchemaJSON :: Value
302+emailSchemaJSON = [aesonQQ|
303+{
304+ "type": "string"
305+}
306+|]
307+
308+-- ========================================================================
309+-- UserId (non-record newtype)
310+-- ========================================================================
311+
312+newtype UserId = UserId Integer
313+ deriving (Eq, Ord, Generic)
314+instance ToSchema UserId
315+
316+userIdSchemaJSON :: Value
317+userIdSchemaJSON = [aesonQQ|
318+{
319+ "type": "integer"
320+}
321+|]
322+
323+-- ========================================================================
324+-- UserGroup (set newtype)
325+-- ========================================================================
326+
327+newtype UserGroup = UserGroup (Set UserId)
328+ deriving (Generic)
329+instance ToSchema UserGroup
330+
331+userGroupSchemaJSON :: Value
332+userGroupSchemaJSON = [aesonQQ|
333+{
334+ "type": "array",
335+ "items": { "$ref": "#/definitions/UserId" },
336+ "uniqueItems": true
337+}
338+|]
339+
340+-- ========================================================================
341+-- Player (record newtype)
342+-- ========================================================================
343+
344+newtype Player = Player
345+ { position :: Point
346+ } deriving (Generic)
347+instance ToSchema Player
348+
349+playerSchemaJSON :: Value
350+playerSchemaJSON = [aesonQQ|
351+{
352+ "type": "object",
353+ "properties":
354+ {
355+ "position":
356+ {
357+ "$ref": "#/definitions/Point"
358+ }
359+ },
360+ "required": ["position"]
361+}
362+|]
363+
364+-- ========================================================================
365+-- MyRoseTree (custom datatypeNameModifier)
366+-- ========================================================================
367+
368+data MyRoseTree = MyRoseTree
369+ { root :: String
370+ , trees :: [MyRoseTree]
371+ } deriving (Generic)
372+
373+instance ToSchema MyRoseTree where
374+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
375+ { datatypeNameModifier = drop (length "My") }
376+
377+myRoseTreeSchemaJSON :: Value
378+myRoseTreeSchemaJSON = [aesonQQ|
379+{
380+ "type": "object",
381+ "properties":
382+ {
383+ "root": { "type": "string" },
384+ "trees":
385+ {
386+ "type": "array",
387+ "items":
388+ {
389+ "$ref": "#/definitions/RoseTree"
390+ }
391+ }
392+ },
393+ "required": ["root", "trees"]
394+}
395+|]
396+
397+-- ========================================================================
398+-- Inlined (newtype for inlining schemas)
399+-- ========================================================================
400+
401+newtype Inlined a = Inlined { getInlined :: a }
402+
403+instance ToSchema a => ToSchema (Inlined a) where
404+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
405+ where
406+ unname (NamedSchema _ s) = NamedSchema Nothing s
407+
408+newtype Players = Players [Inlined Player]
409+ deriving (Generic)
410+instance ToSchema Players
411+
412+playersSchemaJSON :: Value
413+playersSchemaJSON = [aesonQQ|
414+{
415+ "type": "array",
416+ "items":
417+ {
418+ "type": "object",
419+ "properties":
420+ {
421+ "position":
422+ {
423+ "$ref": "#/definitions/Point"
424+ }
425+ },
426+ "required": ["position"]
427+ }
428+}
429+|]
430+
431+-- ========================================================================
432+-- Status (sum type with unary constructors)
433+-- ========================================================================
434+
435+data Status
436+ = StatusOk String
437+ | StatusError String
438+ deriving (Generic)
439+
440+instance ToSchema Status where
441+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
442+ { constructorTagModifier = map toLower . drop (length "Status") }
443+
444+statusSchemaJSON :: Value
445+statusSchemaJSON = [aesonQQ|
446+{
447+ "type": "object",
448+ "properties":
449+ {
450+ "ok": { "type": "string" },
451+ "error": { "type": "string" }
452+ },
453+ "maxProperties": 1,
454+ "minProperties": 1
455+}
456+|]
457+
458+-- ========================================================================
459+-- Unit type
460+-- ========================================================================
461+
462+data Unit = Unit deriving (Generic)
463+instance ToSchema Unit
464+
465+unitSchemaJSON :: Value
466+unitSchemaJSON = [aesonQQ|
467+{
468+ "type": "string",
469+ "enum": ["Unit"]
470+}
471+|]
472+
473+
474+-- ========================================================================
475+-- Character (sum type with ref and record in alternative)
476+-- ========================================================================
477+
478+data Character
479+ = PC Player
480+ | NPC { npcName :: String, npcPosition :: Point }
481+ deriving (Generic)
482+instance ToSchema Character
483+
484+characterSchemaJSON :: Value
485+characterSchemaJSON = [aesonQQ|
486+{
487+ "type": "object",
488+ "properties":
489+ {
490+ "PC": { "$ref": "#/definitions/Player" },
491+ "NPC":
492+ {
493+ "type": "object",
494+ "properties":
495+ {
496+ "npcName": { "type": "string" },
497+ "npcPosition": { "$ref": "#/definitions/Point" }
498+ },
499+ "required": ["npcName", "npcPosition"]
500+ }
501+ },
502+ "maxProperties": 1,
503+ "minProperties": 1
504+}
505+|]
506+
507+characterInlinedSchemaJSON :: Value
508+characterInlinedSchemaJSON = [aesonQQ|
509+{
510+ "type": "object",
511+ "properties":
512+ {
513+ "PC":
514+ {
515+ "type": "object",
516+ "properties":
517+ {
518+ "position":
519+ {
520+ "type": "object",
521+ "properties":
522+ {
523+ "x": { "type": "number", "format": "double" },
524+ "y": { "type": "number", "format": "double" }
525+ },
526+ "required": ["x", "y"]
527+ }
528+ },
529+ "required": ["position"]
530+ },
531+ "NPC":
532+ {
533+ "type": "object",
534+ "properties":
535+ {
536+ "npcName": { "type": "string" },
537+ "npcPosition":
538+ {
539+ "type": "object",
540+ "properties":
541+ {
542+ "x": { "type": "number", "format": "double" },
543+ "y": { "type": "number", "format": "double" }
544+ },
545+ "required": ["x", "y"]
546+ }
547+ },
548+ "required": ["npcName", "npcPosition"]
549+ }
550+ },
551+ "maxProperties": 1,
552+ "minProperties": 1
553+}
554+|]
555+
556+characterInlinedPlayerSchemaJSON :: Value
557+characterInlinedPlayerSchemaJSON = [aesonQQ|
558+{
559+ "type": "object",
560+ "properties":
561+ {
562+ "PC":
563+ {
564+ "type": "object",
565+ "properties":
566+ {
567+ "position":
568+ {
569+ "$ref": "#/definitions/Point"
570+ }
571+ },
572+ "required": ["position"]
573+ },
574+ "NPC":
575+ {
576+ "type": "object",
577+ "properties":
578+ {
579+ "npcName": { "type": "string" },
580+ "npcPosition": { "$ref": "#/definitions/Point" }
581+ },
582+ "required": ["npcName", "npcPosition"]
583+ }
584+ },
585+ "maxProperties": 1,
586+ "minProperties": 1
587+}
588+|]
589+
590+-- ========================================================================
591+-- Light (sum type with unwrapUnaryRecords)
592+-- ========================================================================
593+
594+data Light
595+ = NoLight
596+ | LightFreq Double
597+ | LightColor Color
598+ | LightWaveLength { waveLength :: Double }
599+ deriving (Generic)
600+
601+instance ToSchema Light where
602+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
603+ { unwrapUnaryRecords = True }
604+
605+lightSchemaJSON :: Value
606+lightSchemaJSON = [aesonQQ|
607+{
608+ "type": "object",
609+ "properties":
610+ {
611+ "NoLight": { "type": "array", "items": [] },
612+ "LightFreq": { "type": "number", "format": "double" },
613+ "LightColor": { "$ref": "#/definitions/Color" },
614+ "LightWaveLength": { "type": "number", "format": "double" }
615+ },
616+ "maxProperties": 1,
617+ "minProperties": 1
618+}
619+|]
620+
621+lightInlinedSchemaJSON :: Value
622+lightInlinedSchemaJSON = [aesonQQ|
623+{
624+ "type": "object",
625+ "properties":
626+ {
627+ "NoLight": { "type": "array", "items": [] },
628+ "LightFreq": { "type": "number", "format": "double" },
629+ "LightColor":
630+ {
631+ "type": "string",
632+ "enum": ["Red", "Green", "Blue"]
633+ },
634+ "LightWaveLength": { "type": "number", "format": "double" }
635+ },
636+ "maxProperties": 1,
637+ "minProperties": 1
638+}
639+|]
640+
641+-- ========================================================================
642+-- ResourceId (series of newtypes)
643+-- ========================================================================
644+
645+newtype Id = Id String deriving (Generic)
646+instance ToSchema Id
647+
648+newtype ResourceId = ResourceId Id deriving (Generic)
649+instance ToSchema ResourceId
test/Data/SwaggerSpec.hs+28−114
@@ -10,9 +10,9 @@ import Prelude.Compat
10import Control.Lens
10import Control.Lens
11
11
12import Data.Aeson
12import Data.Aeson
13−import Data.Aeson.QQ.Simple
13+import Data.Aeson.QQ
14import Data.HashMap.Strict (HashMap)
14import Data.HashMap.Strict (HashMap)
15−import qualified Data.HashSet.InsOrd as InsOrdHS
15+import qualified Data.Set as Set
16import Data.Text (Text)
16import Data.Text (Text)
17
17
18import Data.Swagger
18import Data.Swagger
@@ -37,14 +37,11 @@ spec = do
37 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
37 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON
38 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
38 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON
39 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
39 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON
40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON
41 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
40 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON
42 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
41 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON
43 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
42 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON
44 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
43 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON
45 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
44 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON
46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON
47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
48 describe "Swagger Object" $ do
45 describe "Swagger Object" $ do
49 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
46 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
50 context "PetStore Example" $
47 context "PetStore Example" $
@@ -128,7 +125,7 @@ licenseExampleJSON = [aesonQQ|
128
125
129operationExample :: Operation
126operationExample :: Operation
130operationExample = mempty
127operationExample = mempty
131− & tags .~ InsOrdHS.fromList ["pet"]
128+ & tags .~ Set.fromList ["pet"]
132 & summary ?~ "Updates a pet in the store with form data"
129 & summary ?~ "Updates a pet in the store with form data"
133 & description ?~ ""
130 & description ?~ ""
134 & operationId ?~ "updatePetWithForm"
131 & operationId ?~ "updatePetWithForm"
@@ -159,7 +156,7 @@ operationExample = mempty
159 stringSchema :: ParamLocation -> ParamOtherSchema
156 stringSchema :: ParamLocation -> ParamOtherSchema
160 stringSchema loc = mempty
157 stringSchema loc = mempty
161 & in_ .~ loc
158 & in_ .~ loc
162− & type_ ?~ SwaggerString
159+ & type_ .~ SwaggerString
163
160
164operationExampleJSON :: Value
161operationExampleJSON :: Value
165operationExampleJSON = [aesonQQ|
162operationExampleJSON = [aesonQQ|
@@ -225,7 +222,7 @@ operationExampleJSON = [aesonQQ|
225
222
226schemaPrimitiveExample :: Schema
223schemaPrimitiveExample :: Schema
227schemaPrimitiveExample = mempty
224schemaPrimitiveExample = mempty
228− & type_ ?~ SwaggerString
225+ & type_ .~ SwaggerString
229 & format ?~ "email"
226 & format ?~ "email"
230
227
231schemaPrimitiveExampleJSON :: Value
228schemaPrimitiveExampleJSON :: Value
@@ -238,14 +235,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|
238
235
239schemaSimpleModelExample :: Schema
236schemaSimpleModelExample :: Schema
240schemaSimpleModelExample = mempty
237schemaSimpleModelExample = mempty
241− & type_ ?~ SwaggerObject
238+ & type_ .~ SwaggerObject
242 & required .~ [ "name" ]
239 & required .~ [ "name" ]
243 & properties .~
240 & properties .~
244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))
241+ [ ("name", Inline (mempty & type_ .~ SwaggerString))
245 , ("address", Ref (Reference "Address"))
242 , ("address", Ref (Reference "Address"))
246 , ("age", Inline $ mempty
243 , ("age", Inline $ mempty
247 & minimum_ ?~ 0
244 & minimum_ ?~ 0
248− & type_ ?~ SwaggerInteger
245+ & type_ .~ SwaggerInteger
249 & format ?~ "int32" ) ]
246 & format ?~ "int32" ) ]
250
247
251schemaSimpleModelExampleJSON :: Value
248schemaSimpleModelExampleJSON :: Value
@@ -273,8 +270,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|
273
270
274schemaModelDictExample :: Schema
271schemaModelDictExample :: Schema
275schemaModelDictExample = mempty
272schemaModelDictExample = mempty
276− & type_ ?~ SwaggerObject
273+ & type_ .~ SwaggerObject
277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))
274+ & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)
278
275
279schemaModelDictExampleJSON :: Value
276schemaModelDictExampleJSON :: Value
280schemaModelDictExampleJSON = [aesonQQ|
277schemaModelDictExampleJSON = [aesonQQ|
@@ -286,28 +283,15 @@ schemaModelDictExampleJSON = [aesonQQ|
286}
283}
287|]
284|]
288
285
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−
302schemaWithExampleExample :: Schema
286schemaWithExampleExample :: Schema
303schemaWithExampleExample = mempty
287schemaWithExampleExample = mempty
304− & type_ ?~ SwaggerObject
288+ & type_ .~ SwaggerObject
305 & properties .~
289 & properties .~
306 [ ("id", Inline $ mempty
290 [ ("id", Inline $ mempty
307− & type_ ?~ SwaggerInteger
291+ & type_ .~ SwaggerInteger
308 & format ?~ "int64" )
292 & format ?~ "int64" )
309 , ("name", Inline $ mempty
293 , ("name", Inline $ mempty
310− & type_ ?~ SwaggerString) ]
294+ & type_ .~ SwaggerString) ]
311 & required .~ [ "name" ]
295 & required .~ [ "name" ]
312 & example ?~ [aesonQQ|
296 & example ?~ [aesonQQ|
313 {
297 {
@@ -346,19 +330,19 @@ schemaWithExampleExampleJSON = [aesonQQ|
346definitionsExample :: HashMap Text Schema
330definitionsExample :: HashMap Text Schema
347definitionsExample =
331definitionsExample =
348 [ ("Category", mempty
332 [ ("Category", mempty
349− & type_ ?~ SwaggerObject
333+ & type_ .~ SwaggerObject
350 & properties .~
334 & properties .~
351 [ ("id", Inline $ mempty
335 [ ("id", Inline $ mempty
352− & type_ ?~ SwaggerInteger
336+ & type_ .~ SwaggerInteger
353 & format ?~ "int64")
337 & format ?~ "int64")
354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )
338+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )
355 , ("Tag", mempty
339 , ("Tag", mempty
356− & type_ ?~ SwaggerObject
340+ & type_ .~ SwaggerObject
357 & properties .~
341 & properties .~
358 [ ("id", Inline $ mempty
342 [ ("id", Inline $ mempty
359− & type_ ?~ SwaggerInteger
343+ & type_ .~ SwaggerInteger
360 & format ?~ "int64")
344 & format ?~ "int64")
361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]
345+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]
362
346
363definitionsExampleJSON :: Value
347definitionsExampleJSON :: Value
364definitionsExampleJSON = [aesonQQ|
348definitionsExampleJSON = [aesonQQ|
@@ -402,7 +386,7 @@ paramsDefinitionExample =
402 & required ?~ True
386 & required ?~ True
403 & schema .~ ParamOther (mempty
387 & schema .~ ParamOther (mempty
404 & in_ .~ ParamQuery
388 & in_ .~ ParamQuery
405− & type_ ?~ SwaggerInteger
389+ & type_ .~ SwaggerInteger
406 & format ?~ "int32" ))
390 & format ?~ "int32" ))
407 , ("limitParam", mempty
391 , ("limitParam", mempty
408 & name .~ "limit"
392 & name .~ "limit"
@@ -410,7 +394,7 @@ paramsDefinitionExample =
410 & required ?~ True
394 & required ?~ True
411 & schema .~ ParamOther (mempty
395 & schema .~ ParamOther (mempty
412 & in_ .~ ParamQuery
396 & in_ .~ ParamQuery
413− & type_ ?~ SwaggerInteger
397+ & type_ .~ SwaggerInteger
414 & format ?~ "int32" )) ]
398 & format ?~ "int32" )) ]
415
399
416paramsDefinitionExampleJSON :: Value
400paramsDefinitionExampleJSON :: Value
@@ -460,8 +444,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
460-- Responses Definition object
444-- Responses Definition object
461-- =======================================================================
445-- =======================================================================
462
446
463−securityDefinitionsExample :: SecurityDefinitions
447+securityDefinitionsExample :: HashMap Text SecurityScheme
464−securityDefinitionsExample = SecurityDefinitions
448+securityDefinitionsExample =
465 [ ("api_key", SecurityScheme
449 [ ("api_key", SecurityScheme
466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
450 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
467 , _securitySchemeDescription = Nothing })
451 , _securitySchemeDescription = Nothing })
@@ -493,46 +477,6 @@ securityDefinitionsExampleJSON = [aesonQQ|
493}
477}
494|]
478|]
495
479
496−oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions
497−oAuth2SecurityDefinitionsReadExample = SecurityDefinitions
498− [ ("petstore_auth", SecurityScheme
499− { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params
500− { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"
501− , _oauth2Scopes =
502− [ ("read:pets", "read your pets") ] } )
503− , _securitySchemeDescription = Nothing })
504− ]
505−
506−oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions
507−oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions
508− [ ("petstore_auth", SecurityScheme
509− { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params
510− { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"
511− , _oauth2Scopes =
512− [ ("write:pets", "modify pets in your account") ] } )
513− , _securitySchemeDescription = Nothing })
514− ]
515−
516−oAuth2SecurityDefinitionsExample :: SecurityDefinitions
517−oAuth2SecurityDefinitionsExample =
518− oAuth2SecurityDefinitionsWriteExample <>
519− oAuth2SecurityDefinitionsReadExample
520−
521−oAuth2SecurityDefinitionsExampleJSON :: Value
522−oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|
523−{
524− "petstore_auth": {
525− "type": "oauth2",
526− "authorizationUrl": "http://swagger.io/api/oauth/dialog",
527− "flow": "implicit",
528− "scopes": {
529− "write:pets": "modify pets in your account",
530− "read:pets": "read your pets"
531− }
532− }
533−}
534−|]
535−
536-- =======================================================================
480-- =======================================================================
537-- Swagger object
481-- Swagger object
538-- =======================================================================
482-- =======================================================================
@@ -551,7 +495,7 @@ swaggerExample = mempty
551 & at 200 ?~ Inline (mempty
495 & at 200 ?~ Inline (mempty
552 & description .~ "OK"
496 & description .~ "OK"
553 & schema ?~ Inline (mempty
497 & schema ?~ Inline (mempty
554− & type_ ?~ SwaggerObject
498+ & type_ .~ SwaggerObject
555 & example ?~ [aesonQQ|
499 & example ?~ [aesonQQ|
556 {
500 {
557 "created": 100,
501 "created": 100,
@@ -560,9 +504,9 @@ swaggerExample = mempty
560 & description ?~ "This is some real Todo right here"
504 & description ?~ "This is some real Todo right here"
561 & properties .~
505 & properties .~
562 [ ("created", Inline $ mempty
506 [ ("created", Inline $ mempty
563− & type_ ?~ SwaggerInteger
507+ & type_ .~ SwaggerInteger
564 & format ?~ "int32")
508 & format ?~ "int32")
565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))
509+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))
566 & produces ?~ MimeList [ "application/json" ]
510 & produces ?~ MimeList [ "application/json" ]
567 & parameters .~
511 & parameters .~
568 [ Inline $ mempty
512 [ Inline $ mempty
@@ -571,8 +515,8 @@ swaggerExample = mempty
571 & description ?~ "TodoId param"
515 & description ?~ "TodoId param"
572 & schema .~ ParamOther (mempty
516 & schema .~ ParamOther (mempty
573 & in_ .~ ParamPath
517 & in_ .~ ParamPath
574− & type_ ?~ SwaggerString ) ]
518+ & type_ .~ SwaggerString ) ]
575− & tags .~ InsOrdHS.fromList [ "todo" ] ))
519+ & tags .~ Set.fromList [ "todo" ] ))
576
520
577swaggerExampleJSON :: Value
521swaggerExampleJSON :: Value
578swaggerExampleJSON = [aesonQQ|
522swaggerExampleJSON = [aesonQQ|
@@ -1670,33 +1614,3 @@ petstoreExampleJSON = [aesonQQ|
1670 }
1614 }
1671}
1615}
1672|]
1616|]
1673−
1674−compositionSchemaExample :: Schema
1675−compositionSchemaExample = mempty
1676− & type_ ?~ SwaggerObject
1677− & Data.Swagger.allOf ?~ [
1678− Ref (Reference "Other")
1679− , Inline (mempty
1680− & type_ ?~ SwaggerObject
1681− & properties .~
1682− [ ("greet", Inline $ mempty
1683− & type_ ?~ SwaggerString) ])
1684− ]
1685−
1686−compositionSchemaExampleJSON :: Value
1687−compositionSchemaExampleJSON = [aesonQQ|
1688−{
1689− "type": "object",
1690− "allOf": [
1691− {
1692− "$ref": "#/definitions/Other"
1693− },
1694− {
1695− "type": "object",
1696− "properties": {
1697− "greet": { "type": "string" }
1698− }
1699− }
1700− ]
1701−}
1702−|]