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