da4c8d8..master · typeable/swagger2

git.iko.soy/typeable/swagger2

39 files changed+3285−1105

unifiedsplit

.ghci+2−1 .gitignore+2 .travis.yml+150−80 CHANGELOG.md+121−1 LICENSE+1−1 README.md+3−1 Setup.hs+31 aeson-0.11.cabal.config−1 cabal.project+2 examples/hackage.hs+15−1 hackage-docs.sh+78 src/Data/Swagger.hs+48−8 src/Data/Swagger/Declare.hs+77−5 src/Data/Swagger/Internal.hs+147−30 src/Data/Swagger/Internal/AesonUtils.hs+16−3 src/Data/Swagger/Internal/ParamSchema.hs+86−27 src/Data/Swagger/Internal/Schema.hs+192−74 src/Data/Swagger/Internal/Schema/Validation.hs+242−56 src/Data/Swagger/Internal/TypeShape.hs+66 src/Data/Swagger/Internal/Utils.hs−1 src/Data/Swagger/Lens.hs+10−4 src/Data/Swagger/Operation.hs+5−5 src/Data/Swagger/Optics.hs+597 src/Data/Swagger/Schema.hs+15 src/Data/Swagger/Schema/Generator.hs+114 src/Data/Swagger/Schema/Validation.hs+10−1 src/Data/Swagger/SchemaOptions.hs+29 stack-ghc-8.0.yaml−5 stack-lts-2.yaml−17 stack.yaml+6−4 swagger2.cabal+97−47 test/Data/Swagger/CommonTestTypes.hs+679 test/Data/Swagger/ParamSchemaSpec.hs+8−84 test/Data/Swagger/Schema/GeneratorSpec.hs+168 test/Data/Swagger/Schema/ValidationSpec.hs+130−65 test/Data/Swagger/SchemaSpec.hs+12−547 test/Data/SwaggerSpec.hs+114−28 test/DocTest.hs−8 test/doctests.hs+12

.ghci+2−1

@@ -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 @@

11dist

2+dist-newstyle

3+.ghc.environment.*

24cabal-dev

35*.o

46*.hi

.travis.yml+150−80

@@ -1,92 +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+#

29language: c

3−sudo: false

4−

10+dist: xenial

11+git:

12+ # whether to recursively clone submodules

13+ submodules: false

14+branches:

15+ only:

16+ - master

517cache:

618 directories:

7− - $HOME/.cabsnap

819 - $HOME/.cabal/packages

9−

20+ - $HOME/.cabal/store

1021before_cache:

11− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

12− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

13−

22+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

23+ # remove files that are regenerated by 'cabal update'

24+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

25+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

26+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

27+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

28+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

29+ - rm -rfv $CABALHOME/packages/head.hackage

1430matrix:

1531 include:

16− - env: CABALVER=1.18 GHCVER=7.8.4

17− compiler: ": #GHC 7.8.4"

18− addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5], sources: [hvr-ghc]}}

19− - env: CABALVER=1.22 GHCVER=7.10.3

20− compiler: ": #GHC 7.10.3"

21− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5], sources: [hvr-ghc]}}

22− - env: CABALVER=1.24 GHCVER=8.0.1

23− compiler: ": #GHC 8.0.1"

24− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5], sources: [hvr-ghc]}}

25− - env: CABALVER=1.18 GHCVER=7.8.4 CABALCONFIG=aeson-0.11.cabal.config

26− compiler: ": #GHC 7.8.4 aeson-0.11"

27− addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5], sources: [hvr-ghc]}}

28− - env: CABALVER=1.22 GHCVER=7.10.3 CABALCONFIG=aeson-0.11.cabal.config

29− compiler: ": #GHC 7.10.3 aeson-0.11"

30− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5], sources: [hvr-ghc]}}

31− - env: CABALVER=1.24 GHCVER=8.0.1 CABALCONFIG=aeson-0.11.cabal.config

32− compiler: ": #GHC 8.0.1 aeson-0.11"

33− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5], sources: [hvr-ghc]}}

34−

32+ - compiler: ghc-8.8.1

33+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}

34+ - compiler: ghc-8.6.5

35+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}

36+ - compiler: ghc-8.4.4

37+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}

38+ - compiler: ghc-8.2.2

39+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}

40+ - compiler: ghc-8.0.2

41+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}

3542before_install:

36− - unset CC

37− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/1.19.5/bin:$PATH

38− - if [ -f "$CABALCONFIG" ]; then cp $CABALCONFIG cabal.config; fi

39−

43+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')

44+ - WITHCOMPILER="-w $HC"

45+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')

46+ - HCPKG="$HC-pkg"

47+ - unset CC

48+ - CABAL=/opt/ghc/bin/cabal

49+ - CABALHOME=$HOME/.cabal

50+ - export PATH="$CABALHOME/bin:$PATH"

51+ - TOP=$(pwd)

52+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"

53+ - echo $HCNUMVER

54+ - CABAL="$CABAL -vnormal+nowrap+markoutput"

55+ - set -o pipefail

56+ - |

57+ echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk

58+ echo 'BEGIN { state = "output"; }' >> .colorful.awk

59+ echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk

60+ echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk

61+ echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk

62+ echo ' if (state == "cabal") {' >> .colorful.awk

63+ echo ' print blue($0)' >> .colorful.awk

64+ echo ' } else {' >> .colorful.awk

65+ echo ' print $0' >> .colorful.awk

66+ echo ' }' >> .colorful.awk

67+ echo '}' >> .colorful.awk

68+ - cat .colorful.awk

69+ - |

70+ color_cabal_output () {

71+ awk -f $TOP/.colorful.awk

72+ }

73+ - echo text | color_cabal_output

4074install:

41− - cabal --version

42− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

43− - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];

44− then

45− zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >

46− $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;

47− fi

48− - travis_retry cabal update -v

49− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

50− - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt

51− - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt

52−

53−# check whether current requested install-plan matches cached package-db snapshot

54− - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;

55− then

56− echo "cabal build-cache HIT";

57− rm -rfv .ghc;

58− cp -a $HOME/.cabsnap/ghc $HOME/.ghc;

59− cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;

60− else

61− echo "cabal build-cache MISS";

62− rm -rf $HOME/.cabsnap;

63− mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;

64− cabal install --only-dependencies --enable-tests --enable-benchmarks;

65− fi

66−

67−# snapshot package-db on cache miss

68− - if [ ! -d $HOME/.cabsnap ];

69− then

70− echo "snapshotting package-db to build-cache";

71− mkdir $HOME/.cabsnap;

72− cp -a $HOME/.ghc $HOME/.cabsnap/ghc;

73− cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

74− fi

75−

76−# Here starts the actual work to be performed for the package under test;

77−# any command which exits with a non-zero exit code causes the build to fail.

75+ - ${CABAL} --version

76+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

77+ - TEST=--enable-tests

78+ - BENCH=--enable-benchmarks

79+ - HEADHACKAGE=false

80+ - rm -f $CABALHOME/config

81+ - |

82+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config

83+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config

84+ echo "write-ghc-environment-files: always" >> $CABALHOME/config

85+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config

86+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config

87+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config

88+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config

89+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config

90+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config

91+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config

92+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config

93+ echo "install-dirs user" >> $CABALHOME/config

94+ echo " prefix: $CABALHOME" >> $CABALHOME/config

95+ echo "repository hackage.haskell.org" >> $CABALHOME/config

96+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config

97+ echo " secure: True" >> $CABALHOME/config

98+ echo " key-threshold: 3" >> $CABALHOME/config

99+ echo " root-keys:" >> $CABALHOME/config

100+ echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config

101+ echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config

102+ echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config

103+ echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config

104+ echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config

105+ - |

106+ echo "program-default-options" >> $CABALHOME/config

107+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config

108+ - cat $CABALHOME/config

109+ - rm -fv cabal.project cabal.project.local cabal.project.freeze

110+ - travis_retry ${CABAL} v2-update -v

111+ # Generate cabal.project

112+ - rm -rf cabal.project cabal.project.local cabal.project.freeze

113+ - touch cabal.project

114+ - |

115+ echo "packages: ." >> cabal.project

116+ - |

117+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

118+ - cat cabal.project || true

119+ - cat cabal.project.local || true

120+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

121+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output

122+ - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

123+ - rm cabal.project.freeze

124+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output

125+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output

78126script:

79− - if [ -f configure.ac ]; then autoreconf -i; fi

80− - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging

81− - cabal build # this builds all libraries and executables (including tests/benchmarks)

82− - cabal test

83− - cabal check

84− - cabal sdist # tests that a source-distribution can be generated

85−

86−# Check that the resulting source distribution can be built & installed.

87−# If there are no other `.tar.gz` files in `dist`, this can be even simpler:

88−# `cabal install --force-reinstalls dist/*-*.tar.gz`

89− - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&

90− (cd dist && cabal install --force-reinstalls "$SRC_TGZ")

127+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

128+ # Packaging...

129+ - ${CABAL} v2-sdist all | color_cabal_output

130+ # Unpacking...

131+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

132+ - cd ${DISTDIR} || false

133+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;

134+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;

135+ - PKGDIR_swagger2="$(find . -maxdepth 1 -type d -regex '.*/swagger2-[0-9.]*')"

136+ # Generate cabal.project

137+ - rm -rf cabal.project cabal.project.local cabal.project.freeze

138+ - touch cabal.project

139+ - |

140+ echo "packages: ${PKGDIR_swagger2}" >> cabal.project

141+ - |

142+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

143+ - cat cabal.project || true

144+ - cat cabal.project.local || true

145+ # Building...

146+ # this builds all libraries and executables (without tests/benchmarks)

147+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

148+ # Building with tests and benchmarks...

149+ # build & run tests, build benchmarks

150+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

151+ # Testing...

152+ - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

153+ # cabal check...

154+ - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)

155+ # haddock...

156+ - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi

157+ # Building without installed constraints for packages in global-db...

158+ - rm -f cabal.project.local

159+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

91160

161+# REGENDATA ("0.5.20191020",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"])

92162# EOF

CHANGELOG.md+121−1

@@ -1,7 +1,127 @@

1+2.5

2+---

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 ));

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+

11182.1.3

2119-----

3120

4−* Add UUID instances (see [#81](https://github.com/GetShopTV/swagger2/pull/81)).

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))

5125

61262.1.2.1

7127-------

LICENSE+1−1

@@ -1,4 +1,4 @@

22All rights reserved.

44Redistribution and use in source and binary forms, with or without

README.md+3−1

@@ -1,5 +1,7 @@

11# swagger2

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)

35[![Hackage](https://img.shields.io/hackage/v/swagger2.svg)](http://hackage.haskell.org/package/swagger2)

46[![Build Status](https://travis-ci.org/GetShopTV/swagger2.svg?branch=master)](https://travis-ci.org/GetShopTV/swagger2)

57[![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

1113

1214## Usage

1315

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.

1517

1618Please refer to [haddock documentation](http://hackage.haskell.org/package/swagger2).

1719

Setup.hs+31

@@ -1,2 +1,33 @@

1+{-# LANGUAGE CPP #-}

2+{-# OPTIONS_GHC -Wall #-}

3+module Main (main) where

5+#ifndef MIN_VERSION_cabal_doctest

6+#define MIN_VERSION_cabal_doctest(x,y,z) 0

7+#endif

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+

128import Distribution.Simple

29+

30+main :: IO ()

231main = defaultMain

32+

33+#endif

aeson-0.11.cabal.configdeleted−1

@@ -1 +0,0 @@

1−constraints: aeson ==0.11.*

cabal.projectnew file+2

@@ -0,0 +1,2 @@

1+packages: .

2+tests: true

examples/hackage.hs+15−1

@@ -20,7 +20,21 @@ type Username = Text

2020data UserSummary = UserSummary

2121 { summaryUsername :: Username

2222 , 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+

2438

2539type Group = Text

2640

hackage-docs.shnew file+78

@@ -0,0 +1,78 @@

1+#!/bin/bash

2+set -e

4+# This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh

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+48−8

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12-- |

23-- Module: Data.Swagger

34-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

@@ -30,6 +31,7 @@ module Data.Swagger (

3031

3132 -- * Re-exports

3233 module Data.Swagger.Lens,

34+ module Data.Swagger.Optics,

3335 module Data.Swagger.Operation,

3436 module Data.Swagger.ParamSchema,

3537 module Data.Swagger.Schema,

@@ -76,6 +78,7 @@ module Data.Swagger (

7678 SwaggerItems(..),

7779 Xml(..),

7880 Pattern,

81+ AdditionalProperties(..),

7982

8083 -- ** Responses

8184 Responses(..),

@@ -86,6 +89,7 @@ module Data.Swagger (

8689 SecurityScheme(..),

8790 SecuritySchemeType(..),

8891 SecurityRequirement(..),

92+ SecurityDefinitions(..),

8993

9094 -- *** API key

9195 ApiKeyParams(..),

@@ -110,6 +114,7 @@ module Data.Swagger (

110114) where

111115

112116import Data.Swagger.Lens

117+import Data.Swagger.Optics ()

113118import Data.Swagger.Operation

114119import Data.Swagger.ParamSchema

115120import Data.Swagger.Schema

@@ -173,13 +178,15 @@ import Data.Swagger.Internal

173178

174179-- $lens

175180--

181+-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".

182+--

176183-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used

177184-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses

178185-- make it fairly simple to construct/modify any part of the specification:

179186--

180187-- >>> :{

181188-- encode $ (mempty :: Swagger)

182−-- & definitions .~ [ ("User", mempty & type_ .~ SwaggerString) ]

189+-- & definitions .~ [ ("User", mempty & type_ ?~ SwaggerString) ]

183190-- & paths .~

184191-- [ ("/user", mempty & get ?~ (mempty

185192-- & produces ?~ MimeList ["application/json"]

@@ -202,7 +209,7 @@ import Data.Swagger.Internal

202209-- "{\"description\":\"No content\"}"

203210-- >>> :{

204211-- encode $ (mempty :: Schema)

205−-- & type_ .~ SwaggerBoolean

212+-- & type_ ?~ SwaggerBoolean

206213-- & description ?~ "To be or not to be"

207214-- :}

208215-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"

@@ -211,7 +218,7 @@ import Data.Swagger.Internal

211218-- So for convenience, all @'ParamSchema'@ fields are transitively made fields of the type that has it.

212219-- For example, you can use @'type_'@ to access @'SwaggerType'@ of @'Header'@ schema without having to use @'paramSchema'@:

213220--

214−-- >>> encode $ (mempty :: Header) & type_ .~ SwaggerNumber

221+-- >>> encode $ (mempty :: Header) & type_ ?~ SwaggerNumber

215222-- "{\"type\":\"number\"}"

216223--

217224-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and @'Responses'@

@@ -273,7 +280,7 @@ import Data.Swagger.Internal

273280-- >>> encode $ toSchema (Proxy :: Proxy Person)

274281-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"

275282--

276−-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a

283+-- Please note that not all valid Haskell data types will have a proper swagger schema. For example while we can derive a

277284-- schema for basic enums like

278285--

279286-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic

@@ -286,13 +293,46 @@ import Data.Swagger.Internal

286293-- >>> instance ToSchema SampleSumType

287294-- >>> instance ToJSON SampleSumType

288295--

289−-- we can not derive a valid schema for a mix of the above. The following will result in a bad schema

290−--

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

291299-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic

292300-- >>> instance ToSchema BadMixedType

293−-- >>> instance ToJSON 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':

294332--

295−-- This is due to the fact that @'ToJSON'@ encodes empty constructors with an empty list which can not be described in a swagger schema.

333+-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic

334+-- >>> instance ToSchema BadMixedType where declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

335+-- >>> instance ToJSON BadMixedType

296336--

297337

298338-- $manipulation

src/Data/Swagger/Declare.hs+77−5

@@ -2,6 +2,7 @@

22{-# LANGUAGE FlexibleInstances #-}

33{-# LANGUAGE FunctionalDependencies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE UndecidableInstances #-}

56-- |

67-- Module: Data.Swagger.Declare

78-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

@@ -14,9 +15,20 @@ import Prelude ()

1415import Prelude.Compat

1516

1617import Control.Monad

18+import Control.Monad.Cont (ContT)

19+import Control.Monad.List (ListT)

20+import Control.Monad.Reader (ReaderT)

1721import 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

1831import Data.Functor.Identity

19−import Data.Monoid

2032

2133-- | A declare monad transformer parametrized by:

2234--

@@ -37,15 +49,15 @@ instance (Applicative m, Monad m, Monoid d) => Applicative (DeclareT d m) where

3749 pure x = DeclareT (\_ -> pure (mempty, x))

3850 DeclareT df <*> DeclareT dx = DeclareT $ \d -> do

3951 ~(d', f) <- df d

40− ~(d'', x) <- dx (d <> d')

41− return (d' <> d'', f x)

52+ ~(d'', x) <- dx (mappend d d')

53+ return (mappend d' d'', f x)

4254

4355instance (Applicative m, Monad m, Monoid d) => Monad (DeclareT d m) where

4456 return x = DeclareT (\_ -> pure (mempty, x))

4557 DeclareT dx >>= f = DeclareT $ \d -> do

4658 ~(d', x) <- dx d

47− ~(d'', y) <- runDeclareT (f x) (d <> d')

48− return (d' <> d'', y)

59+ ~(d'', y) <- runDeclareT (f x) (mappend d d')

60+ return (mappend d' d'', y)

4961

5062instance Monoid d => MonadTrans (DeclareT d) where

5163 lift m = DeclareT (\_ -> (,) mempty `liftM` m)

@@ -77,6 +89,13 @@ instance (Applicative m, Monad m, Monoid d) => MonadDeclare d (DeclareT d m) whe

7789 declare d = DeclareT (\_ -> return (d, ()))

7890 look = DeclareT (\d -> return (mempty, d))

7991

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+

8099-- | Retrieve a function of all the output so far.

81100looks :: MonadDeclare d m => (d -> a) -> m a

82101looks f = f <$> look

@@ -125,3 +144,56 @@ execDeclare m = runIdentity . execDeclareT m

125144undeclare :: Monoid d => Declare d a -> a

126145undeclare = runIdentity . undeclareT

127146

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+147−30

@@ -29,17 +29,19 @@ import Control.Applicative

2929import Data.Aeson

3030import qualified Data.Aeson.Types as JSON

3131import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)

32+import Data.Hashable (Hashable)

3233import qualified Data.HashMap.Strict as HashMap

34+import Data.HashSet.InsOrd (InsOrdHashSet)

3335import Data.Map (Map)

3436import qualified Data.Map as Map

35−import Data.Monoid

37+import Data.Monoid (Monoid (..))

38+import Data.Semigroup.Compat (Semigroup (..))

3639import Data.Scientific (Scientific)

37−import Data.Set (Set)

3840import Data.String (IsString(..))

3941import Data.Text (Text)

4042import qualified Data.Text as Text

4143import GHC.Generics (Generic)

42−import Network (HostName, PortNumber)

44+import Network.Socket (HostName, PortNumber)

4345import Network.HTTP.Media (MediaType)

4446import Text.Read (readMaybe)

4547

@@ -64,6 +66,10 @@ import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)

6466#define DEFINE_TOENCODING

6567#endif

6668

69+-- $setup

70+-- >>> :seti -XDataKinds

71+-- >>> import Data.Aeson

72+

6773-- | A list of definitions that can be used in references.

6874type Definitions = InsOrdHashMap Text

6975

@@ -111,7 +117,7 @@ data Swagger = Swagger

111117 , _swaggerResponses :: Definitions Response

112118

113119 -- | Security scheme definitions that can be used across the specification.

114− , _swaggerSecurityDefinitions :: Definitions SecurityScheme

120+ , _swaggerSecurityDefinitions :: SecurityDefinitions

115121

116122 -- | A declaration of which security schemes are applied for the API as a whole.

117123 -- The list of values describes alternative security schemes that can be used

@@ -124,7 +130,7 @@ data Swagger = Swagger

124130 -- Not all tags that are used by the Operation Object must be declared.

125131 -- The tags that are not declared may be organized randomly or based on the tools' logic.

126132 -- Each tag name in the list MUST be unique.

127− , _swaggerTags :: Set Tag

133+ , _swaggerTags :: InsOrdHashSet Tag

128134

129135 -- | Additional external documentation.

130136 , _swaggerExternalDocs :: Maybe ExternalDocs

@@ -246,7 +252,7 @@ data PathItem = PathItem

246252data Operation = Operation

247253 { -- | A list of tags for API documentation control.

248254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.

249− _operationTags :: Set TagName

255+ _operationTags :: InsOrdHashSet TagName

250256

251257 -- | A short summary of what the operation does.

252258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.

@@ -303,7 +309,7 @@ data Operation = Operation

303309 } deriving (Eq, Show, Generic, Data, Typeable)

304310

305311newtype MimeList = MimeList { getMimeList :: [MediaType] }

306− deriving (Eq, Show, Monoid, Typeable)

312+ deriving (Eq, Show, Semigroup, Monoid, Typeable)

307313

308314mimeListConstr :: Constr

309315mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix

@@ -554,9 +560,9 @@ data Schema = Schema

554560 , _schemaDescription :: Maybe Text

555561 , _schemaRequired :: [ParamName]

556562

557− , _schemaAllOf :: Maybe [Schema]

563+ , _schemaAllOf :: Maybe [Referenced Schema]

558564 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

559− , _schemaAdditionalProperties :: Maybe (Referenced Schema)

565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties

560566

561567 , _schemaDiscriminator :: Maybe Text

562568 , _schemaReadOnly :: Maybe Bool

@@ -588,7 +594,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema

588594 -- Unlike JSON Schema this value MUST conform to the defined type for this parameter.

589595 _paramSchemaDefault :: Maybe Value

590596

591− , _paramSchemaType :: SwaggerType t

597+ , _paramSchemaType :: Maybe (SwaggerType t)

592598 , _paramSchemaFormat :: Maybe Format

593599 , _paramSchemaItems :: Maybe (SwaggerItems t)

594600 , _paramSchemaMaximum :: Maybe Scientific

@@ -605,7 +611,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema

605611 , _paramSchemaMultipleOf :: Maybe Scientific

606612 } deriving (Eq, Show, Generic, Typeable)

607613

608−deriving instance (Typeable k, Data (SwaggerType k), Data (SwaggerItems k)) => Data (ParamSchema k)

614+deriving instance (Typeable k, Data (Maybe (SwaggerType k)), Data (SwaggerItems k)) => Data (ParamSchema k)

609615

610616data Xml = Xml

611617 { -- | Replaces the name of the element/attribute used for the described schema property.

@@ -749,12 +755,28 @@ data SecurityScheme = SecurityScheme

749755 , _securitySchemeDescription :: Maybe Text

750756 } deriving (Eq, Show, Generic, Data, Typeable)

751757

758+

759+-- | merge scopes of two OAuth2 security schemes when their flows are identical.

760+-- In other case returns first security scheme

761+mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme

762+mergeSecurityScheme s1@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 scopes1)) desc)

763+ s2@(SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow2 scopes2)) _)

764+ = if flow1 == flow2 then

765+ SecurityScheme (SecuritySchemeOAuth2 (OAuth2Params flow1 (scopes1 <> scopes2))) desc

766+ else

767+ s1

768+mergeSecurityScheme s1 _ = s1

769+

770+newtype SecurityDefinitions

771+ = SecurityDefinitions (Definitions SecurityScheme)

772+ deriving (Eq, Show, Generic, Data, Typeable)

773+

752774-- | Lists the required security schemes to execute this operation.

753775-- The object can have multiple security schemes declared in it which are all required

754776-- (that is, there is a logical AND between the schemes).

755777newtype SecurityRequirement = SecurityRequirement

756778 { getSecurityRequirement :: InsOrdHashMap Text [Text]

757− } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable)

779+ } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable)

758780

759781-- | Tag name.

760782type TagName = Text

@@ -773,6 +795,8 @@ data Tag = Tag

773795 , _tagExternalDocs :: Maybe ExternalDocs

774796 } deriving (Eq, Ord, Show, Generic, Data, Typeable)

775797

798+instance Hashable Tag

799+

776800instance IsString Tag where

777801 fromString s = Tag (fromString s) Nothing Nothing

778802

@@ -786,6 +810,8 @@ data ExternalDocs = ExternalDocs

786810 , _externalDocsUrl :: URL

787811 } deriving (Eq, Ord, Show, Generic, Data, Typeable)

788812

813+instance Hashable ExternalDocs

814+

789815-- | A simple object to allow referencing other definitions in the specification.

790816-- It can be used to reference parameters and responses that are defined at the top level for reuse.

791817newtype Reference = Reference { getReference :: Text }

@@ -799,67 +825,111 @@ data Referenced a

799825instance IsString a => IsString (Referenced a) where

800826 fromString = Inline . fromString

801827

802−newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, ToJSON, FromJSON, Data, Typeable)

828+newtype URL = URL { getUrl :: Text } deriving (Eq, Ord, Show, Hashable, ToJSON, FromJSON, Data, Typeable)

829+

830+data AdditionalProperties

831+ = AdditionalPropertiesAllowed Bool

832+ | AdditionalPropertiesSchema (Referenced Schema)

833+ deriving (Eq, Show, Data, Typeable)

803834

804835-- =======================================================================

805836-- Monoid instances

806837-- =======================================================================

807838

839+instance Semigroup Swagger where

840+ (<>) = genericMappend

808841instance Monoid Swagger where

809842 mempty = genericMempty

810− mappend = genericMappend

843+ mappend = (<>)

811844

845+instance Semigroup Info where

846+ (<>) = genericMappend

812847instance Monoid Info where

813848 mempty = genericMempty

814− mappend = genericMappend

849+ mappend = (<>)

815850

851+instance Semigroup Contact where

852+ (<>) = genericMappend

816853instance Monoid Contact where

817854 mempty = genericMempty

818− mappend = genericMappend

855+ mappend = (<>)

819856

857+instance Semigroup PathItem where

858+ (<>) = genericMappend

820859instance Monoid PathItem where

821860 mempty = genericMempty

822− mappend = genericMappend

861+ mappend = (<>)

823862

863+instance Semigroup Schema where

864+ (<>) = genericMappend

824865instance Monoid Schema where

825866 mempty = genericMempty

826− mappend = genericMappend

867+ mappend = (<>)

827868

869+instance Semigroup (ParamSchema t) where

870+ (<>) = genericMappend

828871instance Monoid (ParamSchema t) where

829872 mempty = genericMempty

830− mappend = genericMappend

873+ mappend = (<>)

831874

875+instance Semigroup Param where

876+ (<>) = genericMappend

832877instance Monoid Param where

833878 mempty = genericMempty

834− mappend = genericMappend

879+ mappend = (<>)

835880

881+instance Semigroup ParamOtherSchema where

882+ (<>) = genericMappend

836883instance Monoid ParamOtherSchema where

837884 mempty = genericMempty

838− mappend = genericMappend

885+ mappend = (<>)

839886

887+instance Semigroup Header where

888+ (<>) = genericMappend

840889instance Monoid Header where

841890 mempty = genericMempty

842− mappend = genericMappend

891+ mappend = (<>)

843892

893+instance Semigroup Responses where

894+ (<>) = genericMappend

844895instance Monoid Responses where

845896 mempty = genericMempty

846− mappend = genericMappend

897+ mappend = (<>)

847898

899+instance Semigroup Response where

900+ (<>) = genericMappend

848901instance Monoid Response where

849902 mempty = genericMempty

850− mappend = genericMappend

903+ mappend = (<>)

851904

905+instance Semigroup ExternalDocs where

906+ (<>) = genericMappend

852907instance Monoid ExternalDocs where

853908 mempty = genericMempty

854− mappend = genericMappend

909+ mappend = (<>)

855910

911+instance Semigroup Operation where

912+ (<>) = genericMappend

856913instance Monoid Operation where

857914 mempty = genericMempty

858− mappend = genericMappend

915+ mappend = (<>)

859916

917+instance Semigroup Example where

918+ (<>) = genericMappend

860919instance Monoid Example where

861920 mempty = genericMempty

862− mappend = genericMappend

921+ mappend = (<>)

922+

923+instance Semigroup SecurityScheme where

924+ (<>) = mergeSecurityScheme

925+

926+instance Semigroup SecurityDefinitions where

927+ (SecurityDefinitions sd1) <> (SecurityDefinitions sd2) =

928+ SecurityDefinitions $ InsOrdHashMap.unionWith (<>) sd1 sd2

929+

930+instance Monoid SecurityDefinitions where

931+ mempty = SecurityDefinitions $ InsOrdHashMap.empty

932+ mappend = (<>)

863933

864934-- =======================================================================

865935-- SwaggerMonoid helper instances

@@ -875,6 +945,8 @@ instance SwaggerMonoid Responses

875945instance SwaggerMonoid Response

876946instance SwaggerMonoid ExternalDocs

877947instance SwaggerMonoid Operation

948+instance SwaggerMonoid SecurityDefinitions

949+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)

878950

879951instance SwaggerMonoid MimeList

880952deriving instance SwaggerMonoid URL

@@ -893,7 +965,7 @@ instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where

893965

894966instance Monoid a => SwaggerMonoid (Referenced a) where

895967 swaggerMempty = Inline mempty

896− swaggerMappend (Inline x) (Inline y) = Inline (x <> y)

968+ swaggerMappend (Inline x) (Inline y) = Inline (mappend x y)

897969 swaggerMappend _ y = y

898970

899971instance SwaggerMonoid ParamAnySchema where

@@ -1016,11 +1088,22 @@ instance ToJSON Header where

10161088 toJSON = sopSwaggerGenericToJSON

10171089 DEFINE_TOENCODING

10181090

1091+-- | As for nullary schema for 0-arity type constructors, see

1092+-- <https://github.com/GetShopTV/swagger2/issues/167>.

1093+--

1094+-- >>> encode (SwaggerItemsArray [])

1095+-- "{\"example\":[],\"items\":{},\"maxItems\":0}"

1096+--

10191097instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where

10201098 toJSON (SwaggerItemsPrimitive fmt schema) = object

10211099 [ "collectionFormat" .= fmt

10221100 , "items" .= schema ]

10231101 toJSON (SwaggerItemsObject x) = object [ "items" .= x ]

1102+ toJSON (SwaggerItemsArray []) = object

1103+ [ "items" .= object []

1104+ , "maxItems" .= (0 :: Int)

1105+ , "example" .= Array mempty

1106+ ]

10241107 toJSON (SwaggerItemsArray x) = object [ "items" .= x ]

10251108

10261109instance ToJSON Host where

@@ -1063,6 +1146,9 @@ instance ToJSON PathItem where

10631146instance ToJSON Example where

10641147 toJSON = toJSON . Map.mapKeys show . getExample

10651148

1149+instance ToJSON SecurityDefinitions where

1150+ toJSON (SecurityDefinitions sd) = toJSON sd

1151+

10661152instance ToJSON Reference where

10671153 toJSON (Reference ref) = object [ "$ref" .= ref ]

10681154

@@ -1096,6 +1182,10 @@ instance ToJSON (ParamSchema k) where

10961182 toJSON = sopSwaggerGenericToJSONWithOpts $

10971183 mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

10981184

1185+instance ToJSON AdditionalProperties where

1186+ toJSON (AdditionalPropertiesAllowed b) = toJSON b

1187+ toJSON (AdditionalPropertiesSchema s) = toJSON s

1188+

10991189-- =======================================================================

11001190-- Manual FromJSON instances

11011191-- =======================================================================

@@ -1133,7 +1223,13 @@ instance FromJSON SecurityScheme where

11331223 parseJSON = sopSwaggerGenericParseJSON

11341224

11351225instance FromJSON Schema where

1136− parseJSON = sopSwaggerGenericParseJSON

1226+ parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON

1227+ where nullaryCleanup :: Schema -> Schema

1228+ nullaryCleanup s@Schema{_schemaParamSchema=ps} =

1229+ if _paramSchemaItems ps == Just (SwaggerItemsArray [])

1230+ then s { _schemaExample = Nothing

1231+ , _schemaParamSchema = ps { _paramSchemaMaxItems = Nothing } }

1232+ else s

11371233

11381234instance FromJSON Header where

11391235 parseJSON = sopSwaggerGenericParseJSON

@@ -1148,8 +1244,21 @@ instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where

11481244 <$> o .:? "collectionFormat"

11491245 <*> ((o .: "items" >>= parseJSON) <|> fail ("foo" ++ show o))

11501246

1247+-- |

1248+--

1249+-- >>> decode "{}" :: Maybe (SwaggerItems 'SwaggerKindSchema)

1250+-- Just (SwaggerItemsArray [])

1251+--

1252+-- >>> eitherDecode "{\"$ref\":\"#/definitions/example\"}" :: Either String (SwaggerItems 'SwaggerKindSchema)

1253+-- Right (SwaggerItemsObject (Ref (Reference {getReference = "example"})))

1254+--

1255+-- >>> eitherDecode "[{\"$ref\":\"#/definitions/example\"}]" :: Either String (SwaggerItems 'SwaggerKindSchema)

1256+-- Right (SwaggerItemsArray [Ref (Reference {getReference = "example"})])

1257+--

11511258instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1152− parseJSON js@(Object _) = SwaggerItemsObject <$> parseJSON js

1259+ parseJSON js@(Object obj)

1260+ | null obj = pure $ SwaggerItemsArray [] -- Nullary schema.

1261+ | otherwise = SwaggerItemsObject <$> parseJSON js

11531262 parseJSON js@(Array _) = SwaggerItemsArray <$> parseJSON js

11541263 parseJSON _ = empty

11551264

@@ -1201,6 +1310,9 @@ instance FromJSON Operation where

12011310instance FromJSON PathItem where

12021311 parseJSON = sopSwaggerGenericParseJSON

12031312

1313+instance FromJSON SecurityDefinitions where

1314+ parseJSON js = SecurityDefinitions <$> parseJSON js

1315+

12041316instance FromJSON Reference where

12051317 parseJSON (Object o) = Reference <$> o .: "$ref"

12061318 parseJSON _ = empty

@@ -1251,6 +1363,10 @@ instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where

12511363instance FromJSON (ParamSchema 'SwaggerKindSchema) where

12521364 parseJSON = sopSwaggerGenericParseJSON

12531365

1366+instance FromJSON AdditionalProperties where

1367+ parseJSON (Bool b) = pure $ AdditionalPropertiesAllowed b

1368+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js

1369+

12541370-------------------------------------------------------------------------------

12551371-- TH splices

12561372-------------------------------------------------------------------------------

@@ -1308,3 +1424,4 @@ instance AesonDefaultValue (SwaggerType a)

13081424instance AesonDefaultValue MimeList where defaultValue = Just mempty

13091425instance AesonDefaultValue Info

13101426instance AesonDefaultValue ParamLocation

1427+instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty

src/Data/Swagger/Internal/AesonUtils.hs+16−3

@@ -44,10 +44,10 @@ import qualified Data.Text as T

4444import qualified Data.HashMap.Strict as HM

4545import qualified Data.Set as Set

4646import qualified Data.HashMap.Strict.InsOrd as InsOrd

47+import qualified Data.HashSet.InsOrd as InsOrdHS

4748

4849#if MIN_VERSION_aeson(0,10,0)

4950import Data.Aeson (Encoding, pairs, (.=), Series)

50−import Data.Monoid ((<>))

5151#endif

5252

5353-------------------------------------------------------------------------------

@@ -68,10 +68,10 @@ mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing

6868makeLenses ''SwaggerAesonOptions

6969

7070class (Generic a, All2 AesonDefaultValue (Code a)) => HasSwaggerAesonOptions a where

71− swaggerAesonOptions :: proxy a -> SwaggerAesonOptions

71+ swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

7272

7373 -- So far we use only default definitions

74− aesonDefaults :: proxy a -> POP Maybe (Code a)

74+ aesonDefaults :: Proxy a -> POP Maybe (Code a)

7575 aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue

7676

7777-------------------------------------------------------------------------------

@@ -86,6 +86,7 @@ instance AesonDefaultValue Text where defaultValue = Nothing

8686instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing

8787instance AesonDefaultValue [a] where defaultValue = Just []

8888instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty

89+instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty

8990instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty

9091

9192-------------------------------------------------------------------------------

@@ -145,7 +146,11 @@ sopSwaggerGenericToJSON'

145146 -> DatatypeInfo '[xs]

146147 -> POP Maybe '[xs]

147148 -> [Pair]

149+#if MIN_VERSION_generics_sop(0,5,0)

150+sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =

151+#else

148152sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =

153+#endif

149154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

150155sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"

151156

@@ -221,7 +226,11 @@ sopSwaggerGenericParseJSON'

221226 -> DatatypeInfo '[xs]

222227 -> POP Maybe '[xs]

223228 -> Parser (SOP I '[xs])

229+#if MIN_VERSION_generics_sop(0,5,0)

230+sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =

231+#else

224232sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =

233+#endif

225234 SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs

226235sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"

227236

@@ -293,7 +302,11 @@ sopSwaggerGenericToEncoding'

293302 -> DatatypeInfo '[xs]

294303 -> POP Maybe '[xs]

295304 -> Series

305+#if MIN_VERSION_generics_sop(0,5,0)

306+sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil) _) (POP (defs :* Nil)) =

307+#else

296308sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =

309+#endif

297310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

298311sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"

299312

src/Data/Swagger/Internal/ParamSchema.hs+86−27

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE DefaultSignatures #-}

34{-# LANGUAGE FlexibleContexts #-}

45{-# LANGUAGE FlexibleInstances #-}

@@ -7,17 +8,21 @@

78{-# LANGUAGE PackageImports #-}

89{-# LANGUAGE PolyKinds #-}

910{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

1012{-# LANGUAGE TypeOperators #-}

1113{-# LANGUAGE TypeSynonymInstances #-}

14+{-# LANGUAGE UndecidableInstances #-}

1215#if __GLASGOW_HASKELL__ >= 800

1316-- Generic a is redundant in ToParamSchema a default imple

1417{-# OPTIONS_GHC -Wno-redundant-constraints #-}

18+-- For TypeErrors

19+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

1520#endif

1621#include "overlapping-compat.h"

1722module Data.Swagger.Internal.ParamSchema where

1823

1924import Control.Lens

20−import Data.Aeson

25+import Data.Aeson (ToJSON (..))

2126import Data.Proxy

2227import GHC.Generics

2328

@@ -26,6 +31,7 @@ import "unordered-containers" Data.HashSet (HashSet)

2631import Data.Monoid

2732import Data.Set (Set)

2833import Data.Scientific

34+import Data.Fixed (HasResolution(..), Fixed, Pico)

2935import qualified Data.Text as T

3036import qualified Data.Text.Lazy as TL

3137import Data.Time

@@ -33,30 +39,40 @@ import qualified Data.Vector as V

3339import qualified Data.Vector.Primitive as VP

3440import qualified Data.Vector.Storable as VS

3541import qualified Data.Vector.Unboxed as VU

42+import Data.Version (Version)

43+import Numeric.Natural.Compat (Natural)

3644import Data.Word

3745import Data.UUID.Types (UUID)

46+import Web.Cookie (SetCookie)

3847

3948import Data.Swagger.Internal

4049import Data.Swagger.Lens

4150import Data.Swagger.SchemaOptions

4251

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+

4359-- | Default schema for binary data (any sequence of octets).

4460binaryParamSchema :: ParamSchema t

4561binaryParamSchema = mempty

46− & type_ .~ SwaggerString

62+ & type_ ?~ SwaggerString

4763 & format ?~ "binary"

4864

4965-- | Default schema for binary data (base64 encoded).

5066byteParamSchema :: ParamSchema t

5167byteParamSchema = mempty

52− & type_ .~ SwaggerString

68+ & type_ ?~ SwaggerString

5369 & format ?~ "byte"

5470

5571-- | Default schema for password string.

5672-- @"password"@ format is used to hint UIs the input needs to be obscured.

5773passwordParamSchema :: ParamSchema t

5874passwordParamSchema = mempty

59− & type_ .~ SwaggerString

75+ & type_ ?~ SwaggerString

6076 & format ?~ "password"

6177

6278-- | Convert a type into a plain @'ParamSchema'@.

@@ -71,9 +87,9 @@ passwordParamSchema = mempty

7187-- data Direction = Up | Down

7288--

7389-- instance ToParamSchema Direction where

74−-- toParamSchema = mempty

75−-- & type_ .~ SwaggerString

76−-- & enum_ .~ [ \"Up\", \"Down\" ]

90+-- toParamSchema _ = mempty

91+-- & type_ ?~ SwaggerString

92+-- & enum_ ?~ [ \"Up\", \"Down\" ]

7793-- @

7894--

7995-- Instead of manually writing your @'ToParamSchema'@ instance you can

@@ -99,18 +115,24 @@ class ToParamSchema a where

99115 --

100116 -- >>> encode $ toParamSchema (Proxy :: Proxy Integer)

101117 -- "{\"type\":\"integer\"}"

102− toParamSchema :: proxy a -> ParamSchema t

103− default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => proxy a -> ParamSchema t

118+ toParamSchema :: Proxy a -> ParamSchema t

119+ default toParamSchema :: (Generic a, GToParamSchema (Rep a)) => Proxy a -> ParamSchema t

104120 toParamSchema = genericToParamSchema defaultSchemaOptions

105121

106122instance OVERLAPPING_ ToParamSchema String where

107− toParamSchema _ = mempty & type_ .~ SwaggerString

123+ toParamSchema _ = mempty & type_ ?~ SwaggerString

108124

109125instance ToParamSchema Bool where

110− toParamSchema _ = mempty & type_ .~ SwaggerBoolean

126+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

111127

112128instance ToParamSchema Integer where

113− 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

114136

115137instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral

116138instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral

@@ -132,40 +154,51 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral

132154--

133155-- >>> encode $ toParamSchemaBoundedIntegral (Proxy :: Proxy Int8)

134156-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"

135−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

136158toParamSchemaBoundedIntegral _ = mempty

137− & type_ .~ SwaggerInteger

159+ & type_ ?~ SwaggerInteger

138160 & minimum_ ?~ fromInteger (toInteger (minBound :: a))

139161 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))

140162

141163instance ToParamSchema Char where

142164 toParamSchema _ = mempty

143− & type_ .~ SwaggerString

165+ & type_ ?~ SwaggerString

144166 & maxLength ?~ 1

145167 & minLength ?~ 1

146168

147169instance ToParamSchema Scientific where

148− 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))

149176

150177instance ToParamSchema Double where

151178 toParamSchema _ = mempty

152− & type_ .~ SwaggerNumber

179+ & type_ ?~ SwaggerNumber

153180 & format ?~ "double"

154181

155182instance ToParamSchema Float where

156183 toParamSchema _ = mempty

157− & type_ .~ SwaggerNumber

184+ & type_ ?~ SwaggerNumber

158185 & format ?~ "float"

159186

160187timeParamSchema :: String -> ParamSchema t

161188timeParamSchema fmt = mempty

162− & type_ .~ SwaggerString

189+ & type_ ?~ SwaggerString

163190 & format ?~ T.pack fmt

164191

165192-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.

166193instance ToParamSchema Day where

167194 toParamSchema _ = timeParamSchema "date"

168195

196+-- |

197+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format

198+-- Just "hh:MM:ss"

199+instance ToParamSchema TimeOfDay where

200+ toParamSchema _ = timeParamSchema "hh:MM:ss"

201+

169202-- |

170203-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format

171204-- Just "yyyy-mm-ddThh:MM:ss"

@@ -185,7 +218,7 @@ instance ToParamSchema UTCTime where

185218 toParamSchema _ = timeParamSchema "yyyy-mm-ddThh:MM:ssZ"

186219

187220instance ToParamSchema NominalDiffTime where

188− toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)

221+ toParamSchema _ = toParamSchema (Proxy :: Proxy Pico)

189222

190223instance ToParamSchema T.Text where

191224 toParamSchema _ = toParamSchema (Proxy :: Proxy String)

@@ -193,6 +226,28 @@ instance ToParamSchema T.Text where

193226instance ToParamSchema TL.Text where

194227 toParamSchema _ = toParamSchema (Proxy :: Proxy String)

195228

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+

196251instance ToParamSchema All where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)

197252instance ToParamSchema Any where toParamSchema _ = toParamSchema (Proxy :: Proxy Bool)

198253instance ToParamSchema a => ToParamSchema (Sum a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)

@@ -201,9 +256,11 @@ instance ToParamSchema a => ToParamSchema (First a) where toParamSchema _ = to

201256instance ToParamSchema a => ToParamSchema (Last a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)

202257instance ToParamSchema a => ToParamSchema (Dual a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)

203258

259+instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = toParamSchema (Proxy :: Proxy a)

260+

204261instance ToParamSchema a => ToParamSchema [a] where

205262 toParamSchema _ = mempty

206− & type_ .~ SwaggerArray

263+ & type_ ?~ SwaggerArray

207264 & items ?~ SwaggerItemsPrimitive Nothing (toParamSchema (Proxy :: Proxy a))

208265

209266instance ToParamSchema a => ToParamSchema (V.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])

@@ -223,12 +280,12 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where

223280-- "{\"type\":\"string\",\"enum\":[\"_\"]}"

224281instance ToParamSchema () where

225282 toParamSchema _ = mempty

226− & type_ .~ SwaggerString

283+ & type_ ?~ SwaggerString

227284 & enum_ ?~ ["_"]

228285

229286instance ToParamSchema UUID where

230287 toParamSchema _ = mempty

231− & type_ .~ SwaggerString

288+ & type_ ?~ SwaggerString

232289 & format ?~ "uuid"

233290

234291-- | A configurable generic @'ParamSchema'@ creator.

@@ -237,11 +294,11 @@ instance ToParamSchema UUID where

237294-- >>> data Color = Red | Blue deriving Generic

238295-- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color)

239296-- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}"

240−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

241298genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty

242299

243300class GToParamSchema (f :: * -> *) where

244− gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t

301+ gtoParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t

245302

246303instance GToParamSchema f => GToParamSchema (D1 d f) where

247304 gtoParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy f)

@@ -259,14 +316,14 @@ instance (GEnumParamSchema f, GEnumParamSchema g) => GToParamSchema (f :+: g) wh

259316 gtoParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy (f :+: g))

260317

261318class GEnumParamSchema (f :: * -> *) where

262− genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t

319+ genumParamSchema :: SchemaOptions -> Proxy f -> ParamSchema t -> ParamSchema t

263320

264321instance (GEnumParamSchema f, GEnumParamSchema g) => GEnumParamSchema (f :+: g) where

265322 genumParamSchema opts _ = genumParamSchema opts (Proxy :: Proxy f) . genumParamSchema opts (Proxy :: Proxy g)

266323

267324instance Constructor c => GEnumParamSchema (C1 c U1) where

268325 genumParamSchema opts _ s = s

269− & type_ .~ SwaggerString

326+ & type_ ?~ SwaggerString

270327 & enum_ %~ addEnumValue tag

271328 where

272329 tag = toJSON (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))

@@ -276,3 +333,5 @@ instance Constructor c => GEnumParamSchema (C1 c U1) where

276333

277334data Proxy3 a b c = Proxy3

278335

336+-- $setup

337+-- >>> import Data.Aeson (encode)

src/Data/Swagger/Internal/Schema.hs+192−74

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DefaultSignatures #-}

34{-# LANGUAGE FlexibleContexts #-}

45{-# LANGUAGE FlexibleInstances #-}

@@ -17,6 +18,8 @@

1718#if __GLASGOW_HASKELL__ >= 800

1819-- Few generics related redundant constraints

1920{-# OPTIONS_GHC -Wno-redundant-constraints #-}

21+-- For TypeErrors

22+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

2023#endif

2124#include "overlapping-compat.h"

2225module Data.Swagger.Internal.Schema where

@@ -29,7 +32,7 @@ import Data.Data.Lens (template)

2932

3033import Control.Monad

3134import Control.Monad.Writer

32−import Data.Aeson

35+import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))

3336import Data.Char

3437import Data.Data (Data)

3538import Data.Foldable (traverse_)

@@ -41,9 +44,11 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

4144import Data.Int

4245import Data.IntSet (IntSet)

4346import Data.IntMap (IntMap)

47+import Data.List.NonEmpty.Compat (NonEmpty)

4448import Data.Map (Map)

4549import Data.Proxy

4650import Data.Scientific (Scientific)

51+import Data.Fixed (Fixed, HasResolution, Pico)

4752import Data.Set (Set)

4853import qualified Data.Text as T

4954import qualified Data.Text.Lazy as TL

@@ -52,6 +57,8 @@ import qualified Data.Vector as V

5257import qualified Data.Vector.Primitive as VP

5358import qualified Data.Vector.Storable as VS

5459import qualified Data.Vector.Unboxed as VU

60+import Data.Version (Version)

61+import Numeric.Natural.Compat (Natural)

5562import Data.Word

5663import GHC.Generics

5764import qualified Data.UUID.Types as UUID

@@ -62,10 +69,7 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))

6269import Data.Swagger.Lens hiding (name, schema)

6370import qualified Data.Swagger.Lens as Swagger

6471import Data.Swagger.SchemaOptions

65−

66−#ifdef __DOCTEST__

67−import Data.Swagger.Lens (name, schema)

68−#endif

72+import Data.Swagger.Internal.TypeShape

6973

7074#if __GLASGOW_HASKELL__ < 800

7175#else

@@ -98,14 +102,16 @@ rename name (NamedSchema _ schema) = NamedSchema name schema

98102-- {-\# LANGUAGE OverloadedLists \#-} -- allows to write 'Map' and 'HashMap' as lists

99103--

100104-- import Control.Lens

105+-- import Data.Proxy

106+-- import Data.Swagger

101107--

102108-- data Coord = Coord { x :: Double, y :: Double }

103109--

104110-- instance ToSchema Coord where

105−-- declareNamedSchema = do

111+-- declareNamedSchema _ = do

106112-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)

107−-- return $ NamedSchema (Just \"Coord\")) $ mempty

108−-- & type_ .~ SwaggerObject

113+-- return $ NamedSchema (Just \"Coord\") $ mempty

114+-- & type_ ?~ SwaggerObject

109115-- & properties .~

110116-- [ (\"x\", doubleSchema)

111117-- , (\"y\", doubleSchema)

@@ -136,12 +142,17 @@ class ToSchema a where

136142 -- together with all used definitions.

137143 -- Note that the schema itself is included in definitions

138144 -- only if it is recursive (and thus needs its definition in scope).

139− declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema

140− default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => 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") =>

147+ Proxy a -> Declare (Definitions Schema) NamedSchema

141148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

142149

150+instance ToSchema TimeOfDay where

151+ declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"

152+ & example ?~ toJSON (TimeOfDay 12 33 15)

153+

143154-- | Convert a type into a schema and declare all used schema definitions.

144−declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema

155+declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema

145156declareSchema = fmap _namedSchemaSchema . declareNamedSchema

146157

147158-- | Convert a type into an optionally named schema.

@@ -155,7 +166,7 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema

155166-- Just "Day"

156167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)

157168-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"

158−toNamedSchema :: ToSchema a => proxy a -> NamedSchema

169+toNamedSchema :: ToSchema a => Proxy a -> NamedSchema

159170toNamedSchema = undeclare . declareNamedSchema

160171

161172-- | Get type's schema name according to its @'ToSchema'@ instance.

@@ -165,7 +176,7 @@ toNamedSchema = undeclare . declareNamedSchema

165176--

166177-- >>> schemaName (Proxy :: Proxy UTCTime)

167178-- Just "UTCTime"

168−schemaName :: ToSchema a => proxy a -> Maybe T.Text

179+schemaName :: ToSchema a => Proxy a -> Maybe T.Text

169180schemaName = _namedSchemaName . toNamedSchema

170181

171182-- | Convert a type into a schema.

@@ -175,7 +186,7 @@ schemaName = _namedSchemaName . toNamedSchema

175186--

176187-- >>> encode $ toSchema (Proxy :: Proxy [Day])

177188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"

178−toSchema :: ToSchema a => proxy a -> Schema

189+toSchema :: ToSchema a => Proxy a -> Schema

179190toSchema = _namedSchemaSchema . toNamedSchema

180191

181192-- | Convert a type into a referenced schema if possible.

@@ -186,7 +197,7 @@ toSchema = _namedSchemaSchema . toNamedSchema

186197--

187198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)

188199-- "{\"$ref\":\"#/definitions/Day\"}"

189−toSchemaRef :: ToSchema a => proxy a -> Referenced Schema

200+toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema

190201toSchemaRef = undeclare . declareSchemaRef

191202

192203-- | Convert a type into a referenced schema if possible

@@ -196,7 +207,7 @@ toSchemaRef = undeclare . declareSchemaRef

196207-- Schema definitions are typically declared for every referenced schema.

197208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema

198209-- will be declared (regardless of whether it is recusive or not).

199−declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)

210+declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)

200211declareSchemaRef proxy = do

201212 case toNamedSchema proxy of

202213 NamedSchema (Just name) schema -> do

@@ -258,7 +269,7 @@ inlineAllSchemas = inlineSchemasWhen (const True)

258269--

259270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema

260271-- when inlining recursive schemas.

261−toInlinedSchema :: ToSchema a => proxy a -> Schema

272+toInlinedSchema :: ToSchema a => Proxy a -> Schema

262273toInlinedSchema proxy = inlineAllSchemas defs schema

263274 where

264275 (defs, schema) = runDeclare (declareSchema proxy) mempty

@@ -287,20 +298,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs

287298-- | Default schema for binary data (any sequence of octets).

288299binarySchema :: Schema

289300binarySchema = mempty

290− & type_ .~ SwaggerString

301+ & type_ ?~ SwaggerString

291302 & format ?~ "binary"

292303

293304-- | Default schema for binary data (base64 encoded).

294305byteSchema :: Schema

295306byteSchema = mempty

296− & type_ .~ SwaggerString

307+ & type_ ?~ SwaggerString

297308 & format ?~ "byte"

298309

299310-- | Default schema for password string.

300311-- @"password"@ format is used to hint UIs the input needs to be obscured.

301312passwordSchema :: Schema

302313passwordSchema = mempty

303− & type_ .~ SwaggerString

314+ & type_ ?~ SwaggerString

304315 & format ?~ "password"

305316

306317-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.

@@ -326,12 +337,12 @@ sketchSchema = sketch . toJSON

326337 sketch js@(Bool _) = go js

327338 sketch js = go js & example ?~ js

328339

329− go Null = mempty & type_ .~ SwaggerNull

330− go (Bool _) = mempty & type_ .~ SwaggerBoolean

331− go (String _) = mempty & type_ .~ SwaggerString

332− go (Number _) = mempty & type_ .~ SwaggerNumber

340+ go Null = mempty & type_ ?~ SwaggerNull

341+ go (Bool _) = mempty & type_ ?~ SwaggerBoolean

342+ go (String _) = mempty & type_ ?~ SwaggerString

343+ go (Number _) = mempty & type_ ?~ SwaggerNumber

333344 go (Array xs) = mempty

334− & type_ .~ SwaggerArray

345+ & type_ ?~ SwaggerArray

335346 & items ?~ case ischema of

336347 Just s -> SwaggerItemsObject (Inline s)

337348 _ -> SwaggerItemsArray (map Inline ys)

@@ -343,7 +354,7 @@ sketchSchema = sketch . toJSON

343354 (z:_) | allSame -> Just z

344355 _ -> Nothing

345356 go (Object o) = mempty

346− & type_ .~ SwaggerObject

357+ & type_ ?~ SwaggerObject

347358 & required .~ HashMap.keys o

348359 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

349360

@@ -366,24 +377,24 @@ sketchSchema = sketch . toJSON

366377sketchStrictSchema :: ToJSON a => a -> Schema

367378sketchStrictSchema = go . toJSON

368379 where

369− go Null = mempty & type_ .~ SwaggerNull

380+ go Null = mempty & type_ ?~ SwaggerNull

370381 go js@(Bool _) = mempty

371− & type_ .~ SwaggerBoolean

382+ & type_ ?~ SwaggerBoolean

372383 & enum_ ?~ [js]

373384 go js@(String s) = mempty

374− & type_ .~ SwaggerString

385+ & type_ ?~ SwaggerString

375386 & maxLength ?~ fromIntegral (T.length s)

376387 & minLength ?~ fromIntegral (T.length s)

377388 & pattern ?~ s

378389 & enum_ ?~ [js]

379390 go js@(Number n) = mempty

380− & type_ .~ SwaggerNumber

391+ & type_ ?~ SwaggerNumber

381392 & maximum_ ?~ n

382393 & minimum_ ?~ n

383394 & multipleOf ?~ n

384395 & enum_ ?~ [js]

385396 go js@(Array xs) = mempty

386− & type_ .~ SwaggerArray

397+ & type_ ?~ SwaggerArray

387398 & maxItems ?~ fromIntegral sz

388399 & minItems ?~ fromIntegral sz

389400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))

@@ -393,7 +404,7 @@ sketchStrictSchema = go . toJSON

393404 sz = length xs

394405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))

395406 go js@(Object o) = mempty

396− & type_ .~ SwaggerObject

407+ & type_ ?~ SwaggerObject

397408 & required .~ names

398409 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

399410 & maxProperties ?~ fromIntegral (length names)

@@ -403,18 +414,19 @@ sketchStrictSchema = go . toJSON

403414 names = HashMap.keys o

404415

405416class GToSchema (f :: * -> *) where

406− gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

417+ gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

407418

408419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where

409420 declareNamedSchema _ = do

410421 ref <- declareSchemaRef (Proxy :: Proxy a)

411422 return $ unnamed $ mempty

412− & type_ .~ SwaggerArray

423+ & type_ ?~ SwaggerArray

413424 & items ?~ SwaggerItemsObject ref

414425

415426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

416427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema

417428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema

429+instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema

418430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema

419431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema

420432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema

@@ -434,6 +446,8 @@ instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSc

434446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema

435447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema

436448

449+instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema

450+

437451instance ToSchema a => ToSchema (Maybe a) where

438452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

439453

@@ -456,7 +470,7 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f

456470

457471timeSchema :: T.Text -> Schema

458472timeSchema fmt = mempty

459− & type_ .~ SwaggerString

473+ & type_ ?~ SwaggerString

460474 & format ?~ fmt

461475

462476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.

@@ -477,7 +491,7 @@ instance ToSchema ZonedTime where

477491 & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))

478492

479493instance ToSchema NominalDiffTime where

480− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)

494+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)

481495

482496-- |

483497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format

@@ -489,6 +503,8 @@ instance ToSchema UTCTime where

489503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema

490504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema

491505

506+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema

507+

492508#if __GLASGOW_HASKELL__ < 800

493509#else

494510type family ToSchemaByteStringError bs where

@@ -516,8 +532,8 @@ instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where

516532 declareObjectMapSchema = do

517533 schema <- declareSchemaRef (Proxy :: Proxy v)

518534 return $ unnamed $ mempty

519− & type_ .~ SwaggerObject

520− & additionalProperties ?~ schema

535+ & type_ ?~ SwaggerObject

536+ & additionalProperties ?~ AdditionalPropertiesSchema schema

521537

522538instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where

523539 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))

@@ -528,7 +544,7 @@ instance ToSchema a => ToSchema (Map String a) where

528544 declareNamedSchema _ = do

529545 schema <- declareSchemaRef (Proxy :: Proxy a)

530546 return $ unnamed $ mempty

531− & type_ .~ SwaggerObject

547+ & type_ ?~ SwaggerObject

532548 & additionalProperties ?~ schema

533549

534550instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

@@ -540,6 +556,12 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =

540556

541557#endif

542558

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+

543565instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

544566instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

545567instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

@@ -553,6 +575,13 @@ instance ToSchema a => ToSchema (Set a) where

553575

554576instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))

555577

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+

556585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema

557586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

558587

@@ -562,61 +591,141 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname

562591instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

563592instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

564593

594+instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

595+

565596-- | Default schema for @'Bounded'@, @'Integral'@ types.

566597--

567598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)

568599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"

569−toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema

600+toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema

570601toSchemaBoundedIntegral _ = mempty

571− & type_ .~ SwaggerInteger

602+ & type_ ?~ SwaggerInteger

572603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))

573604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))

574605

575606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.

576−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

607+genericToNamedSchemaBoundedIntegral :: forall a d f.

577608 ( Bounded a, Integral a

578609 , Generic a, Rep a ~ D1 d f, Datatype d)

579− => SchemaOptions -> proxy a -> NamedSchema

610+ => SchemaOptions -> Proxy a -> NamedSchema

580611genericToNamedSchemaBoundedIntegral opts proxy

581− = 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

582668

583669-- | A configurable generic @'Schema'@ creator.

584−genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema

585−genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy

670+genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>

671+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema

672+genericDeclareSchema = genericDeclareSchemaUnrestricted

586673

587674-- | A configurable generic @'NamedSchema'@ creator.

588675-- This function applied to @'defaultSchemaOptions'@

589676-- is used as the default for @'declareNamedSchema'@

590677-- when the type is an instance of @'Generic'@.

591−genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

592−genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

678+genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

679+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema

680+genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

681+

682+-- | A configurable generic @'Schema'@ creator.

683+--

684+-- Unlike 'genericDeclareSchema' also works for mixed sum types.

685+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

686+genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema

687+genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy

688+

689+-- | A configurable generic @'NamedSchema'@ creator.

690+--

691+-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.

692+-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

693+genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>

694+ SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema

695+genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

696+

697+-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.

698+genericNameSchema :: forall a d f.

699+ (Generic a, Rep a ~ D1 d f, Datatype d)

700+ => SchemaOptions -> Proxy a -> Schema -> NamedSchema

701+genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))

593702

594−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

595−gdatatypeSchemaName opts _ = case name of

703+gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text

704+gdatatypeSchemaName opts _ = case orig of

596705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)

597706 _ -> Nothing

598707 where

599− name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))

708+ orig = datatypeName (Proxy3 :: Proxy3 d f a)

709+ name = datatypeNameModifier opts orig

600710

601711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.

602−paramSchemaToNamedSchema :: forall a d f proxy.

603− (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)

604− => SchemaOptions -> proxy a -> NamedSchema

605−paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)

712+paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>

713+ SchemaOptions -> Proxy a -> NamedSchema

714+paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)

606715

607716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.

608−paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema

609−paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)

717+paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema

718+paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy

610719

611720nullarySchema :: Schema

612721nullarySchema = mempty

613− & type_ .~ SwaggerArray

722+ & type_ ?~ SwaggerArray

614723 & items ?~ SwaggerItemsArray []

615724

616−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema

725+gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema

617726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

618727

619−gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema

728+gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema

620729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty

621730

622731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where

@@ -636,7 +745,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where

636745 gdeclareNamedSchema = gdeclareNamedSumSchema

637746

638747-- | Single field constructor.

639−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

640749 gdeclareNamedSchema opts _ s

641750 | unwrapUnaryRecords opts = fieldSchema

642751 | otherwise =

@@ -650,7 +759,7 @@ instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where

650759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s

651760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s

652761

653−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)

762+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)

654763gdeclareSchemaRef opts proxy = do

655764 case gtoNamedSchema opts proxy of

656765 NamedSchema (Just name) schema -> do

@@ -681,10 +790,12 @@ withFieldSchema opts _ isRequiredField schema = do

681790 return $

682791 if T.null fname

683792 then schema

684− & type_ .~ SwaggerArray

793+ & type_ ?~ SwaggerArray

685794 & items %~ appendItem ref

795+ & maxItems %~ Just . maybe 1 (+1) -- increment maxItems

796+ & minItems %~ Just . maybe 1 (+1) -- increment minItems

686797 else schema

687− & type_ .~ SwaggerObject

798+ & type_ ?~ SwaggerObject

688799 & properties . at fname ?~ ref

689800 & if isRequiredField

690801 then required %~ (++ [fname])

@@ -706,10 +817,13 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where

706817instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where

707818 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)

708819

709−instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where

820+instance ( GSumToSchema f

821+ , GSumToSchema g

822+ ) => GToSchema (f :+: g)

823+ where

710824 gdeclareNamedSchema = gdeclareNamedSumSchema

711825

712−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

826+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

713827gdeclareNamedSumSchema opts proxy s

714828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)

715829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema

@@ -718,29 +832,29 @@ gdeclareNamedSumSchema opts proxy s

718832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)

719833

720834 toStringTag schema = mempty

721− & type_ .~ SwaggerString

835+ & type_ ?~ SwaggerString

722836 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)

723837

724838type AllNullary = All

725839

726−class GSumToSchema f where

727− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

840+class GSumToSchema (f :: * -> *) where

841+ gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

728842

729843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where

730844 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)

731845

732−gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>

733− Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema

846+gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>

847+ Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema

734848gsumConToSchemaWith ref opts _ schema = schema

735− & type_ .~ SwaggerObject

849+ & type_ ?~ SwaggerObject

736850 & properties . at tag ?~ ref

737851 & maxProperties ?~ 1

738852 & minProperties ?~ 1

739853 where

740854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))

741855

742−gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>

743− SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema

856+gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>

857+ SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema

744858gsumConToSchema opts proxy schema = do

745859 ref <- gdeclareSchemaRef opts proxy

746860 return $ gsumConToSchemaWith ref opts proxy schema

@@ -762,3 +876,7 @@ data Proxy2 a b = Proxy2

762876

763877data Proxy3 a b c = Proxy3

764878

879+-- $setup

880+-- >>> import Data.Swagger

881+-- >>> import Data.Aeson (encode)

882+-- >>> import Data.Aeson.Types (toJSONKeyText)

src/Data/Swagger/Internal/Schema/Validation.hs+242−56

@@ -1,15 +1,17 @@

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE GADTs #-}

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE GADTs #-}

57{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE PackageImports #-}

9−{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TemplateHaskell #-}

12−{-# LANGUAGE UndecidableInstances #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PackageImports #-}

11+{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TemplateHaskell #-}

14+{-# LANGUAGE UndecidableInstances #-}

1315-- |

1416-- Module: Data.Swagger.Internal.Schema.Validation

@@ -20,28 +22,34 @@

2022-- Validate JSON values with Swagger Schema.

2123module Data.Swagger.Internal.Schema.Validation where

2224

23−import Control.Applicative

24−import Control.Lens

25−import Control.Monad (when)

25+import Prelude ()

26+import Prelude.Compat

2627

27−import Data.Aeson hiding (Result)

28−import Data.Foldable (traverse_, for_, sequenceA_)

29−import Data.HashMap.Strict (HashMap)

30−import qualified Data.HashMap.Strict as HashMap

28+import Control.Applicative

29+import Control.Lens

30+import Control.Monad (when)

31+

32+import Data.Aeson hiding (Result)

33+import Data.Aeson.Encode.Pretty (encodePretty)

34+import Data.Foldable (for_, sequenceA_,

35+ traverse_)

36+import Data.HashMap.Strict (HashMap)

37+import qualified Data.HashMap.Strict as HashMap

38+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

3139import qualified "unordered-containers" Data.HashSet as HashSet

32−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

33−import Data.Monoid

34−import Data.Proxy

35−import Data.Scientific (Scientific, isInteger)

36−import Data.Text (Text)

37−import qualified Data.Text as Text

38−import Data.Vector (Vector)

39−import qualified Data.Vector as Vector

40−

41−import Data.Swagger.Declare

42−import Data.Swagger.Internal

43−import Data.Swagger.Internal.Schema

44−import Data.Swagger.Lens

40+import Data.Proxy

41+import Data.Scientific (Scientific, isInteger)

42+import Data.Text (Text)

43+import qualified Data.Text as Text

44+import qualified Data.Text.Lazy as TL

45+import qualified Data.Text.Lazy.Encoding as TL

46+import Data.Vector (Vector)

47+import qualified Data.Vector as Vector

48+

49+import Data.Swagger.Declare

50+import Data.Swagger.Internal

51+import Data.Swagger.Internal.Schema

52+import Data.Swagger.Lens

4553

4654-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.

4755-- This can be used with QuickCheck to ensure those instances are coherent:

@@ -50,22 +58,119 @@ import Data.Swagger.Lens

5058--

5159-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.

5260-- See @'validateToJSONWithPatternChecker'@.

61+--

62+-- See 'renderValidationErrors' on how the output is structured.

63+validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String

64+validatePrettyToJSON = renderValidationErrors validateToJSON

65+

66+-- | Variant of 'validatePrettyToJSON' with typed output.

5367validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]

5468validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

5569

5670-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.

5771-- This can be used with QuickCheck to ensure those instances are coherent.

5872--

59−-- For validation without patterns see @'validateToJSON'@.

60−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>

61− (Pattern -> Text -> Bool) -> a -> [ValidationError]

62−validateToJSONWithPatternChecker checker x =

73+-- For validation without patterns see @'validateToJSON'@. See also:

74+-- 'renderValidationErrors'.

75+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]

76+validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

77+ where

78+ (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

79+

80+-- | Pretty print validation errors

81+-- together with actual JSON and Swagger Schema

82+-- (using 'encodePretty').

83+--

84+-- >>> import Data.Aeson as Aeson

85+-- >>> import Data.Foldable (traverse_)

86+-- >>> import GHC.Generics

87+-- >>> data Phone = Phone { value :: String } deriving (Generic)

88+-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)

89+-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]

90+-- >>> instance ToSchema Phone

91+-- >>> instance ToSchema Person

92+-- >>> let person = Person { name = "John", phone = Phone "123456" }

93+-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person

94+-- Validation against the schema fails:

95+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"

96+-- <BLANKLINE>

97+-- JSON value:

98+-- {

99+-- "name": "John"

100+-- }

101+-- <BLANKLINE>

102+-- Swagger Schema:

103+-- {

104+-- "required": [

105+-- "name",

106+-- "phone"

107+-- ],

108+-- "type": "object",

109+-- "properties": {

110+-- "phone": {

111+-- "$ref": "#/definitions/Phone"

112+-- },

113+-- "name": {

114+-- "type": "string"

115+-- }

116+-- }

117+-- }

118+-- <BLANKLINE>

119+-- Swagger Description Context:

120+-- {

121+-- "Phone": {

122+-- "required": [

123+-- "value"

124+-- ],

125+-- "type": "object",

126+-- "properties": {

127+-- "value": {

128+-- "type": "string"

129+-- }

130+-- }

131+-- }

132+-- }

133+-- <BLANKLINE>

134+renderValidationErrors

135+ :: forall a. (ToJSON a, ToSchema a)

136+ => (a -> [ValidationError]) -> a -> Maybe String

137+renderValidationErrors f x =

138+ case f x of

139+ [] -> Nothing

140+ errors -> Just $ unlines

141+ [ "Validation against the schema fails:"

142+ , unlines (map (" * " ++) errors)

143+ , "JSON value:"

144+ , ppJSONString (toJSON x)

145+ , ""

146+ , "Swagger Schema:"

147+ , ppJSONString (toJSON schema_)

148+ , ""

149+ , "Swagger Description Context:"

150+ , ppJSONString (toJSON refs_)

151+ ]

152+ where

153+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty

154+ (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

155+

156+-- | Validate JSON @'Value'@ against Swagger @'Schema'@.

157+--

158+-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []

159+--

160+-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.

161+-- See @'validateJSONWithPatternChecker'@.

162+validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]

163+validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)

164+

165+-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.

166+--

167+-- For validation without patterns see @'validateJSON'@.

168+validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]

169+validateJSONWithPatternChecker checker defs sch js =

63170 case runValidation (validateWithSchema js) cfg sch of

64171 Failed xs -> xs

65172 Passed _ -> mempty

66173 where

67− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

68− js = toJSON x

69174 cfg = defaultConfig

70175 { configPatternChecker = checker

71176 , configDefinitions = defs }

@@ -158,12 +263,18 @@ valid = pure ()

158263

159264-- | Validate schema's property given a lens into that property

160265-- and property checker.

161−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

162−check l g = withSchema $ \sch ->

266+checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

267+checkMissing missing l g = withSchema $ \sch ->

163268 case sch ^. l of

164− Nothing -> valid

269+ Nothing -> missing

165270 Just x -> g x

166271

272+-- | Validate schema's property given a lens into that property

273+-- and property checker.

274+-- If property is missing in schema, consider it valid.

275+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

276+check = checkMissing valid

277+

167278-- | Validate same value with different schema.

168279sub :: t -> Validation t a -> Validation s a

169280sub = lmap . const

@@ -292,34 +403,109 @@ validateObject o = withSchema $ \sch ->

292403 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

293404 _ ->

294405 case InsOrdHashMap.lookup k (sch ^. properties) of

295− Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

406+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v

296407 Just s -> validateWithSchemaRef s v

297408

409+ validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid

410+ validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"

411+ validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v

412+

413+ unknownProperty :: Text -> Validation s a

414+ unknownProperty pname = invalid $

415+ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"

416+

298417validateEnum :: Value -> Validation (ParamSchema t) ()

299418validateEnum value = do

300419 check enum_ $ \xs ->

301420 when (value `notElem` xs) $

302421 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

303422

423+-- | Infer schema type based on used properties.

424+--

425+-- This is like 'inferParamSchemaTypes', but also works for objects:

426+--

427+-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"

428+-- Just [SwaggerObject]

429+inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]

430+inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++

431+ [ SwaggerObject | any ($ sch)

432+ [ has (additionalProperties._Just)

433+ , has (maxProperties._Just)

434+ , has (minProperties._Just)

435+ , has (properties.folded)

436+ , has (required.folded) ] ]

437+

438+-- | Infer schema type based on used properties.

439+--

440+-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"

441+-- Just [SwaggerString]

442+--

443+-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"

444+-- Just [SwaggerArray]

445+--

446+-- From numeric properties 'SwaggerInteger' type is inferred.

447+-- If you want 'SwaggerNumber' instead, you must specify it explicitly.

448+--

449+-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"

450+-- Just [SwaggerInteger]

451+inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]

452+inferParamSchemaTypes sch = concat

453+ [ [ SwaggerArray | any ($ sch)

454+ [ has (items._Just)

455+ , has (maxItems._Just)

456+ , has (minItems._Just)

457+ , has (uniqueItems._Just) ] ]

458+ , [ SwaggerInteger | any ($ sch)

459+ [ has (exclusiveMaximum._Just)

460+ , has (exclusiveMinimum._Just)

461+ , has (maximum_._Just)

462+ , has (minimum_._Just)

463+ , has (multipleOf._Just) ] ]

464+ , [ SwaggerString | any ($ sch)

465+ [ has (maxLength._Just)

466+ , has (minLength._Just)

467+ , has (pattern._Just) ] ]

468+ ]

469+

304470validateSchemaType :: Value -> Validation Schema ()

305471validateSchemaType value = withSchema $ \sch ->

306472 case (sch ^. type_, value) of

307− (SwaggerNull, Null) -> valid

308− (SwaggerBoolean, Bool _) -> valid

309− (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

310− (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

311− (SwaggerString, String s) -> sub_ paramSchema (validateString s)

312− (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

313− (SwaggerObject, Object o) -> validateObject o

314− (t, _) -> invalid $ "expected JSON value of type " ++ show t

473+ (Just SwaggerNull, Null) -> valid

474+ (Just SwaggerBoolean, Bool _) -> valid

475+ (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

476+ (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

477+ (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)

478+ (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

479+ (Just SwaggerObject, Object o) -> validateObject o

480+ (Nothing, Null) -> valid

481+ (Nothing, Bool _) -> valid

482+ -- Number by default

483+ (Nothing, Number n) -> sub_ paramSchema (validateNumber n)

484+ (Nothing, String s) -> sub_ paramSchema (validateString s)

485+ (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)

486+ (Nothing, Object o) -> validateObject o

487+ bad -> invalid $ "expected JSON value of type " ++ showType bad

315488

316489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

317490validateParamSchemaType value = withSchema $ \sch ->

318491 case (sch ^. type_, value) of

319− (SwaggerBoolean, Bool _) -> valid

320− (SwaggerInteger, Number n) -> validateInteger n

321− (SwaggerNumber, Number n) -> validateNumber n

322− (SwaggerString, String s) -> validateString s

323− (SwaggerArray, Array xs) -> validateArray xs

324− (t, _) -> invalid $ "expected JSON value of type " ++ show t

325−

492+ (Just SwaggerBoolean, Bool _) -> valid

493+ (Just SwaggerInteger, Number n) -> validateInteger n

494+ (Just SwaggerNumber, Number n) -> validateNumber n

495+ (Just SwaggerString, String s) -> validateString s

496+ (Just SwaggerArray, Array xs) -> validateArray xs

497+ (Nothing, Bool _) -> valid

498+ -- Number by default

499+ (Nothing, Number n) -> validateNumber n

500+ (Nothing, String s) -> validateString s

501+ (Nothing, Array xs) -> validateArray xs

502+ bad -> invalid $ "expected JSON value of type " ++ showType bad

503+

504+showType :: (Maybe (SwaggerType t), Value) -> String

505+showType (Just type_, _) = show type_

506+showType (Nothing, Null) = "SwaggerNull"

507+showType (Nothing, Bool _) = "SwaggerBoolean"

508+showType (Nothing, Number _) = "SwaggerNumber"

509+showType (Nothing, String _) = "SwaggerString"

510+showType (Nothing, Array _) = "SwaggerArray"

511+showType (Nothing, Object _) = "SwaggerObject"

src/Data/Swagger/Internal/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 #-}

9+module Data.Swagger.Internal.TypeShape where

10+

11+import Data.Proxy

12+import GHC.Generics

13+import GHC.TypeLits

14+import GHC.Exts (Constraint)

15+

16+-- | Shape of a datatype.

17+data TypeShape

18+ = Enumeration -- ^ A simple enumeration.

19+ | SumOfProducts -- ^ A product or a sum of non-unit products.

20+ | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.

21+

22+-- | A combined shape for a product type.

23+type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

24+ ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products

25+ ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products

26+ ProdCombine a b = SumOfProducts

27+

28+-- | A combined shape for a sum type.

29+type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

30+ SumCombine Enumeration Enumeration = Enumeration

31+ SumCombine SumOfProducts SumOfProducts = SumOfProducts

32+ SumCombine a b = Mixed

33+

34+type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where

35+ TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))

36+

37+type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where

38+ GenericHasSimpleShape t f Enumeration = ()

39+ GenericHasSimpleShape t f SumOfProducts = ()

40+#if __GLASGOW_HASKELL__ < 800

41+ GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t

42+

43+class CannotDeriveSchemaForMixedSumType t where

44+#else

45+ GenericHasSimpleShape t f Mixed =

46+ TypeError

47+ ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t

48+ :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."

49+ :$$: Text "Swagger does not have a good representation for these types."

50+ :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"

51+ :$$: Text "that matches aeson's Generic-based toJSON,"

52+ :$$: Text "but that's not supported by some Swagger tools."

53+ )

54+#endif

55+

56+-- | Infer a 'TypeShape' for a generic representation of a type.

57+type family GenericShape (g :: * -> *) :: TypeShape

58+

59+type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)

60+type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)

61+type instance GenericShape (D1 d f) = GenericShape f

62+type instance GenericShape (C1 c U1) = Enumeration

63+type instance GenericShape (C1 c (S1 s f)) = SumOfProducts

64+type instance GenericShape (C1 c (f :*: g)) = SumOfProducts

65+

66+

src/Data/Swagger/Internal/Utils.hs−1

@@ -21,7 +21,6 @@ import qualified Data.HashMap.Strict as HashMap

2121import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

2222import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

2323import Data.Map (Map)

24−import Data.Monoid

2524import Data.Set (Set)

2625import Data.Text (Text)

2726import GHC.Generics

src/Data/Swagger/Lens.hs+10−4

@@ -96,13 +96,19 @@ instance At Responses where at n = responses . at n

9696instance Ixed Operation where ix n = responses . ix n

9797instance At Operation where at n = responses . at n

9898

99+type instance Index SecurityDefinitions = Text

100+type instance IxValue SecurityDefinitions = SecurityScheme

101+

102+instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n

103+instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n

104+

99105instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

100106

101107-- HasType instances

102−instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_

103−instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

104−instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

105−instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_

108+instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_

109+instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

110+instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

111+instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_

106112

107113-- HasDefault instances

108114instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

src/Data/Swagger/Operation.hs+5−5

@@ -37,7 +37,7 @@ import Control.Lens

3737import Data.Data.Lens

3838import Data.List.Compat

3939import Data.Maybe (mapMaybe)

40−import Data.Monoid

40+import Data.Proxy

4141import qualified Data.Set as Set

4242

4343import Data.Swagger.Declare

@@ -46,6 +46,7 @@ import Data.Swagger.Lens

4646import Data.Swagger.Schema

4747

4848import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

49+import qualified Data.HashSet.InsOrd as InsOrdHS

4950

5051-- $setup

5152-- >>> import Data.Aeson

@@ -111,15 +112,15 @@ applyTags = applyTagsFor allOperations

111112-- list of tags.

112113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

113114applyTagsFor ops ts swag = swag

114− & ops . tags %~ (<> Set.fromList (map _tagName ts))

115− & tags %~ (<> Set.fromList ts)

115+ & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))

116+ & tags %~ (<> InsOrdHS.fromList ts)

116117

117118-- | Construct a response with @'Schema'@ while declaring all

118119-- necessary schema definitions.

119120--

120121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

121122-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

122−declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

123+declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response

123124declareResponse proxy = do

124125 s <- declareSchemaRef proxy

125126 return (mempty & schema ?~ s)

@@ -190,4 +191,3 @@ setResponseForWith ops f code dres swag = swag

190191 Nothing -> new -- response name can't be dereferenced, replacing with new response

191192 combine (Just (Inline old)) = f old new

192193 combine Nothing = new

193−

src/Data/Swagger/Optics.hsnew file+597

@@ -0,0 +1,597 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE OverloadedLabels #-}

5+{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE UndecidableInstances #-}

8+{-# OPTIONS_GHC -fno-warn-orphans #-}

9+-- |

10+-- Module: Data.Swagger.Optics

11+-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>

12+-- Stability: experimental

13+--

14+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>

15+-- library.

16+--

17+-- >>> import Data.Aeson

18+-- >>> import Optics.Core

19+-- >>> :set -XOverloadedLabels

20+--

21+-- Example from the "Data.Swagger" module using @optics@:

22+--

23+-- >>> :{

24+-- encode $ (mempty :: Swagger)

25+-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]

26+-- & #paths .~

27+-- [ ("/user", mempty & #get ?~ (mempty

28+-- & #produces ?~ MimeList ["application/json"]

29+-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))

30+-- & at 404 ?~ "User info not found")) ]

31+-- :}

32+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"

33+--

34+-- For convenience optics are defined as /labels/. It means that field accessor

35+-- names can be overloaded for different types. One such common field is

36+-- @#description@. Many components of a Swagger specification can have

37+-- descriptions, and you can use the same name for them:

38+--

39+-- >>> encode $ (mempty :: Response) & #description .~ "No content"

40+-- "{\"description\":\"No content\"}"

41+-- >>> :{

42+-- encode $ (mempty :: Schema)

43+-- & #type ?~ SwaggerBoolean

44+-- & #description ?~ "To be or not to be"

45+-- :}

46+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"

47+--

48+-- @'ParamSchema'@ is basically the /base schema specification/ and many types

49+-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively

50+-- made fields of the type that has it. For example, you can use @#type@ to

51+-- access @'SwaggerType'@ of @'Header'@ schema without having to use

52+-- @#paramSchema@:

53+--

54+-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber

55+-- "{\"type\":\"number\"}"

56+--

57+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and

58+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:

59+--

60+-- >>> :{

61+-- encode $ (mempty :: Operation)

62+-- & at 404 ?~ "Not found"

63+-- :}

64+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"

65+--

66+module Data.Swagger.Optics () where

67+

68+import Data.Aeson (Value)

69+import Data.Scientific (Scientific)

70+import Data.Swagger.Internal

71+import Data.Text (Text)

72+import Optics.Core

73+import Optics.TH

74+

75+-- Lenses

76+

77+makeFieldLabels ''Swagger

78+makeFieldLabels ''Host

79+makeFieldLabels ''Info

80+makeFieldLabels ''Contact

81+makeFieldLabels ''License

82+makeFieldLabels ''PathItem

83+makeFieldLabels ''Tag

84+makeFieldLabels ''Operation

85+makeFieldLabels ''Param

86+makeFieldLabels ''ParamOtherSchema

87+makeFieldLabels ''Header

88+makeFieldLabels ''Schema

89+makeFieldLabels ''NamedSchema

90+makeFieldLabels ''ParamSchema

91+makeFieldLabels ''Xml

92+makeFieldLabels ''Responses

93+makeFieldLabels ''Response

94+makeFieldLabels ''SecurityScheme

95+makeFieldLabels ''ApiKeyParams

96+makeFieldLabels ''OAuth2Params

97+makeFieldLabels ''ExternalDocs

98+

99+-- Prisms

100+

101+makePrismLabels ''ParamAnySchema

102+makePrismLabels ''SecuritySchemeType

103+makePrismLabels ''Referenced

104+

105+-- SwaggerItems prisms

106+

107+instance

108+ ( a ~ [Referenced Schema]

109+ , b ~ [Referenced Schema]

110+ ) => LabelOptic "_SwaggerItemsArray"

111+ A_Review

112+ (SwaggerItems 'SwaggerKindSchema)

113+ (SwaggerItems 'SwaggerKindSchema)

114+ a

115+ b where

116+ labelOptic = unto (\x -> SwaggerItemsArray x)

117+ {-# INLINE labelOptic #-}

118+

119+instance

120+ ( a ~ Referenced Schema

121+ , b ~ Referenced Schema

122+ ) => LabelOptic "_SwaggerItemsObject"

123+ A_Review

124+ (SwaggerItems 'SwaggerKindSchema)

125+ (SwaggerItems 'SwaggerKindSchema)

126+ a

127+ b where

128+ labelOptic = unto (\x -> SwaggerItemsObject x)

129+ {-# INLINE labelOptic #-}

130+

131+instance

132+ ( a ~ (Maybe (CollectionFormat t), ParamSchema t)

133+ , b ~ (Maybe (CollectionFormat t), ParamSchema t)

134+ ) => LabelOptic "_SwaggerItemsPrimitive"

135+ A_Review

136+ (SwaggerItems t)

137+ (SwaggerItems t)

138+ a

139+ b where

140+ labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)

141+ {-# INLINE labelOptic #-}

142+

143+-- =============================================================

144+-- More helpful instances for easier access to schema properties

145+

146+type instance Index Responses = HttpStatusCode

147+type instance Index Operation = HttpStatusCode

148+

149+type instance IxValue Responses = Referenced Response

150+type instance IxValue Operation = Referenced Response

151+

152+instance Ixed Responses where

153+ ix n = #responses % ix n

154+ {-# INLINE ix #-}

155+instance At Responses where

156+ at n = #responses % at n

157+ {-# INLINE at #-}

158+

159+instance Ixed Operation where

160+ ix n = #responses % ix n

161+ {-# INLINE ix #-}

162+instance At Operation where

163+ at n = #responses % at n

164+ {-# INLINE at #-}

165+

166+-- #paramSchema

167+

168+instance

169+ ( a ~ ParamSchema 'SwaggerKindSchema

170+ , b ~ ParamSchema 'SwaggerKindSchema

171+ ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where

172+ labelOptic = #schema % #paramSchema

173+ {-# INLINE labelOptic #-}

174+

175+-- #type

176+

177+instance

178+ ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

179+ , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

180+ ) => LabelOptic "type" A_Lens Header Header a b where

181+ labelOptic = #paramSchema % #type

182+ {-# INLINE labelOptic #-}

183+

184+instance

185+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

186+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

187+ ) => LabelOptic "type" A_Lens Schema Schema a b where

188+ labelOptic = #paramSchema % #type

189+ {-# INLINE labelOptic #-}

190+

191+instance

192+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

193+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

194+ ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where

195+ labelOptic = #paramSchema % #type

196+ {-# INLINE labelOptic #-}

197+

198+instance

199+ ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

200+ , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

201+ ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where

202+ labelOptic = #paramSchema % #type

203+ {-# INLINE labelOptic #-}

204+

205+-- #default

206+

207+instance

208+ ( a ~ Maybe Value, b ~ Maybe Value

209+ ) => LabelOptic "default" A_Lens Header Header a b where

210+ labelOptic = #paramSchema % #default

211+ {-# INLINE labelOptic #-}

212+

213+instance

214+ ( a ~ Maybe Value, b ~ Maybe Value

215+ ) => LabelOptic "default" A_Lens Schema Schema a b where

216+ labelOptic = #paramSchema % #default

217+ {-# INLINE labelOptic #-}

218+

219+instance

220+ ( a ~ Maybe Value, b ~ Maybe Value

221+ ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where

222+ labelOptic = #paramSchema % #default

223+ {-# INLINE labelOptic #-}

224+

225+instance

226+ ( a ~ Maybe Value, b ~ Maybe Value

227+ ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where

228+ labelOptic = #paramSchema % #default

229+ {-# INLINE labelOptic #-}

230+

231+-- #format

232+

233+instance

234+ ( a ~ Maybe Format, b ~ Maybe Format

235+ ) => LabelOptic "format" A_Lens Header Header a b where

236+ labelOptic = #paramSchema % #format

237+ {-# INLINE labelOptic #-}

238+

239+instance

240+ ( a ~ Maybe Format, b ~ Maybe Format

241+ ) => LabelOptic "format" A_Lens Schema Schema a b where

242+ labelOptic = #paramSchema % #format

243+ {-# INLINE labelOptic #-}

244+

245+instance

246+ ( a ~ Maybe Format, b ~ Maybe Format

247+ ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where

248+ labelOptic = #paramSchema % #format

249+ {-# INLINE labelOptic #-}

250+

251+instance

252+ ( a ~ Maybe Format, b ~ Maybe Format

253+ ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where

254+ labelOptic = #paramSchema % #format

255+ {-# INLINE labelOptic #-}

256+

257+-- #items

258+

259+instance

260+ ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

261+ , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

262+ ) => LabelOptic "items" A_Lens Header Header a b where

263+ labelOptic = #paramSchema % #items

264+ {-# INLINE labelOptic #-}

265+

266+instance

267+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

268+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

269+ ) => LabelOptic "items" A_Lens Schema Schema a b where

270+ labelOptic = #paramSchema % #items

271+ {-# INLINE labelOptic #-}

272+

273+instance

274+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

275+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

276+ ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where

277+ labelOptic = #paramSchema % #items

278+ {-# INLINE labelOptic #-}

279+

280+instance

281+ ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

282+ , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

283+ ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where

284+ labelOptic = #paramSchema % #items

285+ {-# INLINE labelOptic #-}

286+

287+-- #maximum

288+

289+instance

290+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

291+ ) => LabelOptic "maximum" A_Lens Header Header a b where

292+ labelOptic = #paramSchema % #maximum

293+ {-# INLINE labelOptic #-}

294+

295+instance

296+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

297+ ) => LabelOptic "maximum" A_Lens Schema Schema a b where

298+ labelOptic = #paramSchema % #maximum

299+ {-# INLINE labelOptic #-}

300+

301+instance

302+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

303+ ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where

304+ labelOptic = #paramSchema % #maximum

305+ {-# INLINE labelOptic #-}

306+

307+instance

308+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

309+ ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

310+ labelOptic = #paramSchema % #maximum

311+ {-# INLINE labelOptic #-}

312+

313+-- #exclusiveMaximum

314+

315+instance

316+ ( a ~ Maybe Bool, b ~ Maybe Bool

317+ ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where

318+ labelOptic = #paramSchema % #exclusiveMaximum

319+ {-# INLINE labelOptic #-}

320+

321+instance

322+ ( a ~ Maybe Bool, b ~ Maybe Bool

323+ ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where

324+ labelOptic = #paramSchema % #exclusiveMaximum

325+ {-# INLINE labelOptic #-}

326+

327+instance

328+ ( a ~ Maybe Bool, b ~ Maybe Bool

329+ ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where

330+ labelOptic = #paramSchema % #exclusiveMaximum

331+ {-# INLINE labelOptic #-}

332+

333+instance

334+ ( a ~ Maybe Bool, b ~ Maybe Bool

335+ ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

336+ labelOptic = #paramSchema % #exclusiveMaximum

337+ {-# INLINE labelOptic #-}

338+

339+-- #minimum

340+

341+instance

342+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

343+ ) => LabelOptic "minimum" A_Lens Header Header a b where

344+ labelOptic = #paramSchema % #minimum

345+ {-# INLINE labelOptic #-}

346+

347+instance

348+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

349+ ) => LabelOptic "minimum" A_Lens Schema Schema a b where

350+ labelOptic = #paramSchema % #minimum

351+ {-# INLINE labelOptic #-}

352+

353+instance

354+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

355+ ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where

356+ labelOptic = #paramSchema % #minimum

357+ {-# INLINE labelOptic #-}

358+

359+instance

360+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

361+ ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

362+ labelOptic = #paramSchema % #minimum

363+ {-# INLINE labelOptic #-}

364+

365+-- #exclusiveMinimum

366+

367+instance

368+ ( a ~ Maybe Bool, b ~ Maybe Bool

369+ ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where

370+ labelOptic = #paramSchema % #exclusiveMinimum

371+ {-# INLINE labelOptic #-}

372+

373+instance

374+ ( a ~ Maybe Bool, b ~ Maybe Bool

375+ ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where

376+ labelOptic = #paramSchema % #exclusiveMinimum

377+ {-# INLINE labelOptic #-}

378+

379+instance

380+ ( a ~ Maybe Bool, b ~ Maybe Bool

381+ ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where

382+ labelOptic = #paramSchema % #exclusiveMinimum

383+ {-# INLINE labelOptic #-}

384+

385+instance

386+ ( a ~ Maybe Bool, b ~ Maybe Bool

387+ ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

388+ labelOptic = #paramSchema % #exclusiveMinimum

389+ {-# INLINE labelOptic #-}

390+

391+-- #maxLength

392+

393+instance

394+ ( a ~ Maybe Integer, b ~ Maybe Integer

395+ ) => LabelOptic "maxLength" A_Lens Header Header a b where

396+ labelOptic = #paramSchema % #maxLength

397+ {-# INLINE labelOptic #-}

398+

399+instance

400+ ( a ~ Maybe Integer, b ~ Maybe Integer

401+ ) => LabelOptic "maxLength" A_Lens Schema Schema a b where

402+ labelOptic = #paramSchema % #maxLength

403+ {-# INLINE labelOptic #-}

404+

405+instance

406+ ( a ~ Maybe Integer, b ~ Maybe Integer

407+ ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where

408+ labelOptic = #paramSchema % #maxLength

409+ {-# INLINE labelOptic #-}

410+

411+instance

412+ ( a ~ Maybe Integer, b ~ Maybe Integer

413+ ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

414+ labelOptic = #paramSchema % #maxLength

415+ {-# INLINE labelOptic #-}

416+

417+-- #minLength

418+

419+instance

420+ ( a ~ Maybe Integer, b ~ Maybe Integer

421+ ) => LabelOptic "minLength" A_Lens Header Header a b where

422+ labelOptic = #paramSchema % #minLength

423+ {-# INLINE labelOptic #-}

424+

425+instance

426+ ( a ~ Maybe Integer, b ~ Maybe Integer

427+ ) => LabelOptic "minLength" A_Lens Schema Schema a b where

428+ labelOptic = #paramSchema % #minLength

429+ {-# INLINE labelOptic #-}

430+

431+instance

432+ ( a ~ Maybe Integer, b ~ Maybe Integer

433+ ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where

434+ labelOptic = #paramSchema % #minLength

435+ {-# INLINE labelOptic #-}

436+

437+instance

438+ ( a ~ Maybe Integer, b ~ Maybe Integer

439+ ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

440+ labelOptic = #paramSchema % #minLength

441+ {-# INLINE labelOptic #-}

442+

443+-- #pattern

444+

445+instance

446+ ( a ~ Maybe Text, b ~ Maybe Text

447+ ) => LabelOptic "pattern" A_Lens Header Header a b where

448+ labelOptic = #paramSchema % #pattern

449+ {-# INLINE labelOptic #-}

450+

451+instance

452+ ( a ~ Maybe Text, b ~ Maybe Text

453+ ) => LabelOptic "pattern" A_Lens Schema Schema a b where

454+ labelOptic = #paramSchema % #pattern

455+ {-# INLINE labelOptic #-}

456+

457+instance

458+ ( a ~ Maybe Text, b ~ Maybe Text

459+ ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where

460+ labelOptic = #paramSchema % #pattern

461+ {-# INLINE labelOptic #-}

462+

463+instance

464+ ( a ~ Maybe Text, b ~ Maybe Text

465+ ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where

466+ labelOptic = #paramSchema % #pattern

467+ {-# INLINE labelOptic #-}

468+

469+-- #maxItems

470+

471+instance

472+ ( a ~ Maybe Integer, b ~ Maybe Integer

473+ ) => LabelOptic "maxItems" A_Lens Header Header a b where

474+ labelOptic = #paramSchema % #maxItems

475+ {-# INLINE labelOptic #-}

476+

477+instance

478+ ( a ~ Maybe Integer, b ~ Maybe Integer

479+ ) => LabelOptic "maxItems" A_Lens Schema Schema a b where

480+ labelOptic = #paramSchema % #maxItems

481+ {-# INLINE labelOptic #-}

482+

483+instance

484+ ( a ~ Maybe Integer, b ~ Maybe Integer

485+ ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where

486+ labelOptic = #paramSchema % #maxItems

487+ {-# INLINE labelOptic #-}

488+

489+instance

490+ ( a ~ Maybe Integer, b ~ Maybe Integer

491+ ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

492+ labelOptic = #paramSchema % #maxItems

493+ {-# INLINE labelOptic #-}

494+

495+-- #minItems

496+

497+instance

498+ ( a ~ Maybe Integer, b ~ Maybe Integer

499+ ) => LabelOptic "minItems" A_Lens Header Header a b where

500+ labelOptic = #paramSchema % #minItems

501+ {-# INLINE labelOptic #-}

502+

503+instance

504+ ( a ~ Maybe Integer, b ~ Maybe Integer

505+ ) => LabelOptic "minItems" A_Lens Schema Schema a b where

506+ labelOptic = #paramSchema % #minItems

507+ {-# INLINE labelOptic #-}

508+

509+instance

510+ ( a ~ Maybe Integer, b ~ Maybe Integer

511+ ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where

512+ labelOptic = #paramSchema % #minItems

513+ {-# INLINE labelOptic #-}

514+

515+instance

516+ ( a ~ Maybe Integer, b ~ Maybe Integer

517+ ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

518+ labelOptic = #paramSchema % #minItems

519+ {-# INLINE labelOptic #-}

520+

521+-- #uniqueItems

522+

523+instance

524+ ( a ~ Maybe Bool, b ~ Maybe Bool

525+ ) => LabelOptic "uniqueItems" A_Lens Header Header a b where

526+ labelOptic = #paramSchema % #uniqueItems

527+ {-# INLINE labelOptic #-}

528+

529+instance

530+ ( a ~ Maybe Bool, b ~ Maybe Bool

531+ ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where

532+ labelOptic = #paramSchema % #uniqueItems

533+ {-# INLINE labelOptic #-}

534+

535+instance

536+ ( a ~ Maybe Bool, b ~ Maybe Bool

537+ ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where

538+ labelOptic = #paramSchema % #uniqueItems

539+ {-# INLINE labelOptic #-}

540+

541+instance

542+ ( a ~ Maybe Bool, b ~ Maybe Bool

543+ ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

544+ labelOptic = #paramSchema % #uniqueItems

545+ {-# INLINE labelOptic #-}

546+

547+-- #enum

548+

549+instance

550+ ( a ~ Maybe [Value], b ~ Maybe [Value]

551+ ) => LabelOptic "enum" A_Lens Header Header a b where

552+ labelOptic = #paramSchema % #enum

553+ {-# INLINE labelOptic #-}

554+

555+instance

556+ ( a ~ Maybe [Value], b ~ Maybe [Value]

557+ ) => LabelOptic "enum" A_Lens Schema Schema a b where

558+ labelOptic = #paramSchema % #enum

559+ {-# INLINE labelOptic #-}

560+

561+instance

562+ ( a ~ Maybe [Value], b ~ Maybe [Value]

563+ ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where

564+ labelOptic = #paramSchema % #enum

565+ {-# INLINE labelOptic #-}

566+

567+instance

568+ ( a ~ Maybe [Value], b ~ Maybe [Value]

569+ ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where

570+ labelOptic = #paramSchema % #enum

571+ {-# INLINE labelOptic #-}

572+

573+-- #multipleOf

574+

575+instance

576+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

577+ ) => LabelOptic "multipleOf" A_Lens Header Header a b where

578+ labelOptic = #paramSchema % #multipleOf

579+ {-# INLINE labelOptic #-}

580+

581+instance

582+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

583+ ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where

584+ labelOptic = #paramSchema % #multipleOf

585+ {-# INLINE labelOptic #-}

586+

587+instance

588+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

589+ ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where

590+ labelOptic = #paramSchema % #multipleOf

591+ {-# INLINE labelOptic #-}

592+

593+instance

594+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

595+ ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where

596+ labelOptic = #paramSchema % #multipleOf

597+ {-# INLINE labelOptic #-}

src/Data/Swagger/Schema.hs+15

@@ -17,11 +17,25 @@ module Data.Swagger.Schema (

1717 -- * Generic schema encoding

1818 genericDeclareNamedSchema,

1919 genericDeclareSchema,

20+ genericDeclareNamedSchemaNewtype,

21+ genericNameSchema,

22+

23+ -- ** 'Bounded' 'Integral'

2024 genericToNamedSchemaBoundedIntegral,

2125 toSchemaBoundedIntegral,

26+

27+ -- ** 'Bounded' 'Enum' key mappings

28+ declareSchemaBoundedEnumKeyMapping,

29+ toSchemaBoundedEnumKeyMapping,

30+

31+ -- ** Reusing 'ToParamSchema'

2232 paramSchemaToNamedSchema,

2333 paramSchemaToSchema,

2434

35+ -- ** Unrestricted versions

36+ genericDeclareNamedSchemaUnrestricted,

37+ genericDeclareSchemaUnrestricted,

38+

2539 -- * Schema templates

2640 passwordSchema,

2741 binarySchema,

@@ -40,6 +54,7 @@ module Data.Swagger.Schema (

4054 -- * Generic encoding configuration

4155 SchemaOptions(..),

4256 defaultSchemaOptions,

57+ fromAesonOptions,

4358) where

4459

4560import 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 #-}

5+module Data.Swagger.Schema.Generator where

7+import Prelude ()

8+import Prelude.Compat

10+import Control.Lens.Operators

11+import Control.Monad (filterM)

12+import Data.Aeson

13+import Data.Aeson.Types

14+import qualified Data.HashMap.Strict.InsOrd as M

15+import Data.Maybe

16+import Data.Maybe

17+import Data.Proxy

18+import Data.Scientific

19+import qualified Data.Set as S

20+import Data.Swagger

21+import Data.Swagger.Declare

22+import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)

23+import qualified Data.Text as T

24+import qualified Data.Vector as V

25+import Test.QuickCheck (arbitrary)

26+import Test.QuickCheck.Gen

27+import Test.QuickCheck.Property

28+

29+-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30+-- and cannot be inferred.

31+schemaGen :: Definitions Schema -> Schema -> Gen Value

32+schemaGen _ schema

33+ | Just cases <- schema ^. paramSchema . enum_ = elements cases

34+schemaGen defns schema =

35+ case schema ^. type_ of

36+ Nothing ->

37+ case inferSchemaTypes schema of

38+ [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

39+ -- Gen is not MonadFail

40+ _ -> error "unable to infer schema type"

41+ Just SwaggerBoolean -> Bool <$> elements [True, False]

42+ Just SwaggerNull -> pure Null

43+ Just SwaggerNumber

44+ | Just min <- schema ^. minimum_

45+ , Just max <- schema ^. maximum_ ->

46+ Number . fromFloatDigits <$>

47+ choose (toRealFloat min, toRealFloat max :: Double)

48+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

49+ Just SwaggerInteger

50+ | Just min <- schema ^. minimum_

51+ , Just max <- schema ^. maximum_ ->

52+ Number . fromInteger <$>

53+ choose (truncate min, truncate max)

54+ | otherwise -> Number . fromInteger <$> arbitrary

55+ Just SwaggerArray

56+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

57+ | Just items <- schema ^. items ->

58+ case items of

59+ SwaggerItemsObject ref -> do

60+ size <- getSize

61+ let itemSchema = dereference defns ref

62+ minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems

63+ maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems

64+ arrayLength <- choose (minLength', max minLength' maxLength')

65+ generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema

66+ return . Array $ V.fromList generatedArray

67+ SwaggerItemsArray refs ->

68+ let itemGens = schemaGen defns . dereference defns <$> refs

69+ in fmap (Array . V.fromList) $ sequence itemGens

70+ Just SwaggerString -> do

71+ size <- getSize

72+ let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

73+ let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

74+ length <- choose (minLength', max minLength' maxLength')

75+ str <- vectorOf length arbitrary

76+ return . String $ T.pack str

77+ Just SwaggerObject -> do

78+ size <- getSize

79+ let props = dereference defns <$> schema ^. properties

80+ reqKeys = S.fromList $ schema ^. required

81+ allKeys = S.fromList . M.keys $ schema ^. properties

82+ optionalKeys = allKeys S.\\ reqKeys

83+ minProps' = fromMaybe (length reqKeys) $

84+ fromInteger <$> schema ^. minProperties

85+ maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties

86+ shuffledOptional <- shuffle $ S.toList optionalKeys

87+ numProps <- choose (minProps', max minProps' maxProps')

88+ let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional

89+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props

90+ let gens = schemaGen defns <$> presentProps

91+ additionalGens <- case schema ^. additionalProperties of

92+ Just (AdditionalPropertiesSchema addlSchema) -> do

93+ additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary

94+ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

95+ _ -> return []

96+ x <- sequence $ gens <> additionalGens

97+ return . Object $ M.toHashMap x

98+ where

99+ dereference :: Definitions a -> Referenced a -> a

100+ dereference _ (Inline a) = a

101+ dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

102+

103+genValue :: (ToSchema a) => Proxy a -> Gen Value

104+genValue p =

105+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty

106+ in schemaGen defs schema

107+

108+validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property

109+validateFromJSON p = forAll (genValue p) $

110+ \val -> case parseEither parseJSON val of

111+ Right (_ :: a) -> succeeded

112+ Left err -> failed

113+ { reason = err

114+ }

src/Data/Swagger/Schema/Validation.hs+10−1

@@ -15,9 +15,18 @@ module Data.Swagger.Schema.Validation (

1515 -- $maybe

1616

1717 -- * JSON validation

18+

19+ ValidationError,

20+

21+ -- ** Using 'ToJSON' and 'ToSchema'

22+ validatePrettyToJSON,

1823 validateToJSON,

1924 validateToJSONWithPatternChecker,

20− ValidationError,

25+ renderValidationErrors,

26+

27+ -- ** Using 'Value' and 'Schema'

28+ validateJSON,

29+ validateJSONWithPatternChecker,

2130) where

2231

2332import Data.Swagger.Internal.Schema.Validation

src/Data/Swagger/SchemaOptions.hs+29

@@ -1,3 +1,4 @@

1+{-# LANGUAGE RecordWildCards #-}

12-- |

23-- Module: Data.Swagger.SchemaOptions

34-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

@@ -6,6 +7,8 @@

67-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.

78module Data.Swagger.SchemaOptions where

10+import qualified Data.Aeson.Types as Aeson

11+

912-- | Options that specify how to encode your type to Swagger schema.

1013data SchemaOptions = SchemaOptions

1114 { -- | Function applied to field labels. Handy for removing common record prefixes for example.

@@ -41,3 +44,29 @@ defaultSchemaOptions = SchemaOptions

4144 , unwrapUnaryRecords = False

4245 }

4346

47+-- | Convert 'Aeson.Options' to 'SchemaOptions'.

48+--

49+-- Specifically the following fields get copied:

50+--

51+-- * 'fieldLabelModifier'

52+-- * 'constructorTagModifier'

53+-- * 'allNullaryToStringTag'

54+-- * 'unwrapUnaryRecords'

55+--

56+-- Note that these fields have no effect on `SchemaOptions`:

57+--

58+-- * 'Aeson.omitNothingFields'

59+-- * 'Aeson.sumEncoding'

60+-- * 'Aeson.tagSingleConstructors'

61+--

62+-- The rest is defined as in 'defaultSchemaOptions'.

63+--

64+-- @since 2.2.1

65+--

66+fromAesonOptions :: Aeson.Options -> SchemaOptions

67+fromAesonOptions opts = defaultSchemaOptions

68+ { fieldLabelModifier = Aeson.fieldLabelModifier opts

69+ , constructorTagModifier = Aeson.constructorTagModifier opts

70+ , allNullaryToStringTag = Aeson.allNullaryToStringTag opts

71+ , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts

72+ }

stack-ghc-8.0.yamldeleted−5

@@ -1,5 +0,0 @@

1−resolver: nightly-2016-05-29

2−packages:

3−- '.'

4−extra-deps:

5− - aeson-0.11.2.1

stack-lts-2.yamldeleted−17

@@ -1,17 +0,0 @@

1−flags: {}

2−packages:

3−- '.'

4−extra-deps:

5−- aeson-0.11.2.1

6−- attoparsec-0.13.1.0

7−- base-compat-0.9.1

8−- fail-4.9.0.0

9−- generics-sop-0.2.1.0

10−- insert-ordered-containers-0.1.0.1

11−- primitive-0.6.1.0

12−- tagged-0.8.4

13−- unordered-containers-0.2.7.0

14−resolver: lts-2.22

15−flags:

16− aeson:

17− old-locale: true

stack.yaml+6−4

@@ -1,7 +1,9 @@

1−flags: {}

1+resolver: lts-14.3

22packages:

33- '.'

44extra-deps:

5−- aeson-1.0.0.0

6−- insert-ordered-containers-0.2.0.0

7−resolver: nightly-2016-07-15

5+- optics-core-0.2

6+- optics-th-0.2

7+- optics-extra-0.2

8+- indexed-profunctors-0.1

9+- insert-ordered-containers-0.2.3

swagger2.cabal+97−47

@@ -1,7 +1,15 @@

1+cabal-version: >=1.10

12name: swagger2

2−version: 2.1.3

3+version: 2.5

35synopsis: Swagger 2.0 data model

4−description: Please see README.md

6+category: Web, Swagger

7+description:

8+ This library is intended to be used for decoding and encoding Swagger 2.0 API

9+ specifications as well as manipulating them.

10+ .

11+ The original Swagger 2.0 specification is available at http://swagger.io/specification/.

12+

513homepage: https://github.com/GetShopTV/swagger2

614bug-reports: https://github.com/GetShopTV/swagger2/issues

715license: BSD3

@@ -9,15 +17,22 @@ license-file: LICENSE

917author: Nickolay Kudasov

1018maintainer: nickolay@getshoptv.com

12−category: Web

13−build-type: Simple

20+build-type: Custom

1421extra-source-files:

1522 README.md

1623 , CHANGELOG.md

1724 , examples/*.hs

1825 , include/overlapping-compat.h

19−cabal-version: >=1.10

20−tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1

26+tested-with:

27+ GHC ==8.0.2

28+ || ==8.2.2

29+ || ==8.4.4

30+ || ==8.6.5

31+ || ==8.8.1

32+

33+custom-setup

34+ setup-depends:

35+ base, Cabal, cabal-doctest >=1.0.6 && <1.1

2136

2237library

2338 hs-source-dirs: src

@@ -27,8 +42,10 @@ library

2742 Data.Swagger.Declare

2843 Data.Swagger.Lens

2944 Data.Swagger.Operation

45+ Data.Swagger.Optics

3046 Data.Swagger.ParamSchema

3147 Data.Swagger.Schema

48+ Data.Swagger.Schema.Generator

3249 Data.Swagger.Schema.Validation

3350 Data.Swagger.SchemaOptions

3451

@@ -39,64 +56,97 @@ library

3956 Data.Swagger.Internal.ParamSchema

4057 Data.Swagger.Internal.Utils

4158 Data.Swagger.Internal.AesonUtils

42− build-depends: base >=4.7 && <4.10

43− , base-compat >=0.9.1 && <0.10

44− , aeson >=0.11.2.1

45− , bytestring

46− , containers

47− , hashable

48− , generics-sop >=0.2 && <0.3

49− , http-media

50− , insert-ordered-containers >=0.1.0.0 && <0.3

51− , lens

52− , mtl

53− , network

54− , scientific

55− , text

56− , template-haskell

57− , time

58− , transformers

59− , unordered-containers

60− , vector

61− , uuid-types >=1.0.2 && <1.1

59+ Data.Swagger.Internal.TypeShape

60+

61+ -- GHC boot libraries

62+ build-depends:

63+ base >=4.9 && <4.14

64+ , aeson-pretty >=0.8.7 && <0.9

65+ , bytestring >=0.10.4.0 && <0.11

66+ , containers >=0.5.5.1 && <0.7

67+ , template-haskell >=2.9.0.0 && <2.16

68+ , time >=1.4.2 && <1.10

69+ , transformers >=0.3.0.0 && <0.6

70+

71+ build-depends:

72+ mtl >=2.1 && <2.3

73+ , text >=1.2.3.0 && <1.3

74+

75+ -- other dependencies

76+ build-depends:

77+ base-compat-batteries >=0.10.4 && <0.12

78+ , aeson >=1.4.2.0 && <1.5

79+ -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

80+ , cookie >=0.4.3 && <0.5

81+ , generics-sop >=0.3.2.0 && <0.6

82+ , hashable >=1.2.7.0 && <1.4

83+ , http-media >=0.7.1.2 && <0.9

84+ , insert-ordered-containers >=0.2.3 && <0.3

85+ , lens >=4.16.1 && <4.19

86+ , network >=2.6.3.5 && <3.2

87+ , optics-core >=0.2 && <0.3

88+ , optics-th >=0.2 && <0.3

89+ , scientific >=0.3.6.2 && <0.4

90+ , transformers-compat >=0.3 && <0.7

91+ , unordered-containers >=0.2.9.0 && <0.3

92+ , uuid-types >=1.0.3 && <1.1

93+ , vector >=0.12.0.1 && <0.13

94+ , QuickCheck >=2.10.1 && <2.14

95+

6296 default-language: Haskell2010

6397

6498test-suite spec

6599 type: exitcode-stdio-1.0

66100 hs-source-dirs: test

67101 main-is: Spec.hs

102+

103+ -- From library parat

68104 -- We need aeson's toEncoding for doctests too

69− build-depends: base

70− , base-compat

71− , aeson >=0.10.0.0

72− , aeson-qq

73− , bytestring

74− , containers

75− , hashable

76− , hspec

77− , insert-ordered-containers

78− , HUnit

79− , mtl

80− , QuickCheck

81− , swagger2

82− , text

83− , time

84− , unordered-containers

85− , vector

86− , lens

105+ build-depends:

106+ base

107+ , swagger2

108+ , aeson

109+ , base-compat-batteries

110+ , bytestring

111+ , containers

112+ , hashable

113+ , insert-ordered-containers

114+ , lens

115+ , mtl

116+ , template-haskell

117+ , text

118+ , time

119+ , unordered-containers

120+ , vector

121+ , QuickCheck

122+

123+ -- test-suite only dependencies

124+ build-depends:

125+ hspec >=2.5.5 && <2.8

126+ , HUnit >=1.6.0.0 && <1.7

127+ , quickcheck-instances >=0.3.19 && <0.14

128+ , utf8-string >=1.0.1.1 && <1.1

129+

130+ -- https://github.com/haskell/cabal/issues/3708

131+ build-tool-depends:

132+ hspec-discover:hspec-discover >=2.5.5 && <2.8

133+

87134 other-modules:

88135 SpecCommon

89136 Data.SwaggerSpec

137+ Data.Swagger.CommonTestTypes

90138 Data.Swagger.ParamSchemaSpec

91139 Data.Swagger.SchemaSpec

92140 Data.Swagger.Schema.ValidationSpec

141+ Data.Swagger.Schema.GeneratorSpec

93142 default-language: Haskell2010

94143

95−test-suite doctest

96− build-depends: base, doctest, Glob

144+test-suite doctests

145+ -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes

146+ build-depends: base, doctest, Glob, QuickCheck

97147 default-language: Haskell2010

98148 hs-source-dirs: test

99− main-is: DocTest.hs

149+ main-is: doctests.hs

100150 type: exitcode-stdio-1.0

101151

102152source-repository head

test/Data/Swagger/CommonTestTypes.hsnew file+679

@@ -0,0 +1,679 @@

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE QuasiQuotes #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

5+module Data.Swagger.CommonTestTypes where

7+import Prelude ()

8+import Prelude.Compat

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 @@

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE TemplateHaskell #-}

55{-# LANGUAGE QuasiQuotes #-}

6+{-# LANGUAGE OverloadedStrings #-}

67module Data.Swagger.ParamSchemaSpec where

89import Data.Aeson

9−import Data.Aeson.QQ

10+import Data.Aeson.QQ.Simple

1011import Data.Char

1112import Data.Proxy

1213import GHC.Generics

@@ -14,11 +15,15 @@ import GHC.Generics

1415import Data.Swagger

1516import Data.Swagger.Internal (SwaggerKind(..))

1617

18+import Data.Swagger.CommonTestTypes

1719import SpecCommon

1820import Test.Hspec

21+import Data.Time.LocalTime

22+

23+import qualified Data.HashMap.Strict as HM

1924

2025checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

21−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema (SwaggerKindNormal Param)) <=> js

26+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

2227

2328spec :: Spec

2429spec = do

@@ -29,88 +34,7 @@ spec = do

2934 context "Unary records" $ do

3035 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

3136 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

3238

3339main :: IO ()

3440main = hspec spec

35−

36−-- ========================================================================

37−-- Unit type

38−-- ========================================================================

39−

40−data Unit = Unit deriving (Generic)

41−instance ToParamSchema Unit

42−

43−unitSchemaJSON :: Value

44−unitSchemaJSON = [aesonQQ|

45−{

46− "type": "string",

47− "enum": ["Unit"]

48−}

49−|]

50−

51−-- ========================================================================

52−-- Color (enum)

53−-- ========================================================================

54−data Color

55− = Red

56− | Green

57− | Blue

58− deriving (Generic)

59−instance ToParamSchema Color

60−

61−colorSchemaJSON :: Value

62−colorSchemaJSON = [aesonQQ|

63−{

64− "type": "string",

65− "enum": ["Red", "Green", "Blue"]

66−}

67−|]

68−

69−-- ========================================================================

70−-- Status (constructorTagModifier)

71−-- ========================================================================

72−

73−data Status = StatusOk | StatusError deriving (Generic)

74−

75−instance ToParamSchema Status where

76− toParamSchema = genericToParamSchema defaultSchemaOptions

77− { constructorTagModifier = map toLower . drop (length "Status") }

78−

79−statusSchemaJSON :: Value

80−statusSchemaJSON = [aesonQQ|

81−{

82− "type": "string",

83− "enum": ["ok", "error"]

84−}

85−|]

86−

87−-- ========================================================================

88−-- Email (newtype with unwrapUnaryRecords set to True)

89−-- ========================================================================

90−

91−newtype Email = Email { getEmail :: String }

92− deriving (Generic)

93−instance ToParamSchema Email

94−

95−emailSchemaJSON :: Value

96−emailSchemaJSON = [aesonQQ|

97−{

98− "type": "string"

99−}

100−|]

101−

102−-- ========================================================================

103−-- UserId (non-record newtype)

104−-- ========================================================================

105−

106−newtype UserId = UserId Integer

107− deriving (Generic)

108−instance ToParamSchema UserId

109−

110−userIdSchemaJSON :: Value

111−userIdSchemaJSON = [aesonQQ|

112−{

113− "type": "integer"

114−}

115−|]

116−

test/Data/Swagger/Schema/GeneratorSpec.hsnew file+168

@@ -0,0 +1,168 @@

1+{-# LANGUAGE OverloadedLists #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE PackageImports #-}

4+module Data.Swagger.Schema.GeneratorSpec where

6+import Prelude ()

7+import Prelude.Compat

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 #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE PackageImports #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE PackageImports #-}

4+{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# OPTIONS_GHC -fno-warn-orphans #-}

47module Data.Swagger.Schema.ValidationSpec where

6−import Control.Applicative

7−import Data.Aeson

8−import Data.Aeson.Types

9−import Data.Int

10−import Data.IntMap (IntMap)

11−import qualified Data.IntMap as IntMap

12−import Data.IntSet (IntSet)

13−import Data.Hashable (Hashable)

14−import "unordered-containers" Data.HashSet (HashSet)

9+import Control.Applicative

10+import Control.Lens ((&), (.~), (?~))

11+import Data.Aeson

12+import Data.Aeson.Types

13+import Data.Hashable (Hashable)

14+import Data.HashMap.Strict (HashMap)

15+import qualified Data.HashMap.Strict as HashMap

16+import "unordered-containers" Data.HashSet (HashSet)

1517import qualified "unordered-containers" Data.HashSet as HashSet

16−import Data.HashMap.Strict (HashMap)

17−import qualified Data.HashMap.Strict as HashMap

18−import Data.Map (Map)

19−import qualified Data.Map as Map

20−import Data.Proxy

21−import Data.Time

22−import qualified Data.Text as T

23−import qualified Data.Text.Lazy as TL

24−import Data.Set (Set)

25−import qualified Data.Set as Set

26−import Data.Word

27−import GHC.Generics

28−

29−import Data.Swagger

30−import Data.Swagger.Declare

31−import Data.Swagger.Schema.Validation

32−

33−import SpecCommon

34−import Test.Hspec

35−import Test.Hspec.QuickCheck

36−import Test.QuickCheck

18+import Data.Int

19+import Data.IntMap (IntMap)

20+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

21+import Data.Map (Map, fromList)

22+import Data.Monoid (mempty)

23+import Data.Proxy

24+import Data.Set (Set)

25+import qualified Data.Text as T

26+import qualified Data.Text.Lazy as TL

27+import Data.Time

28+import Data.Version (Version)

29+import Data.Word

30+import GHC.Generics

31+

32+import Data.Swagger

33+import Data.Swagger.Declare

34+

35+import Test.Hspec

36+import Test.Hspec.QuickCheck

37+import Test.QuickCheck

38+import Test.QuickCheck.Instances ()

3739

3840shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

3941shouldValidate _ x = validateToJSON x == []

4042

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+

4148spec :: Spec

4249spec = do

4350 describe "Validation" $ do

@@ -66,6 +73,7 @@ spec = do

6673 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

6774 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

6875 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

76+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

6977 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

7078 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

7179 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

@@ -75,6 +83,7 @@ spec = do

7583 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

7684 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

7785 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

86+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)

7887 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

7988 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

8089 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

@@ -83,6 +92,16 @@ spec = do

8392 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

8493 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

8594 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

86105

87106main :: IO ()

88107main = hspec spec

@@ -102,6 +121,13 @@ instance ToSchema Person

102121instance Arbitrary Person where

103122 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

104123

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+

105131-- ========================================================================

106132-- Color (enum)

107133-- ========================================================================

@@ -113,6 +139,11 @@ instance ToSchema Color

113139instance Arbitrary Color where

114140 arbitrary = arbitraryBoundedEnum

115141

142+invalidColorToJSON :: Color -> Value

143+invalidColorToJSON Red = toJSON "red"

144+invalidColorToJSON Green = toJSON "green"

145+invalidColorToJSON Blue = toJSON "blue"

146+

116147-- ========================================================================

117148-- Paint (record with bounded enum property)

118149-- ========================================================================

@@ -126,6 +157,9 @@ instance ToSchema Paint

126157instance Arbitrary Paint where

127158 arbitrary = Paint <$> arbitrary

128159

160+invalidPaintToJSON :: Paint -> Value

161+invalidPaintToJSON = toJSON . color

162+

129163-- ========================================================================

130164-- MyRoseTree (custom datatypeNameModifier)

131165-- ========================================================================

@@ -154,7 +188,8 @@ instance Arbitrary MyRoseTree where

154188

155189data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)

156190

157−instance ToSchema Light

191+instance ToSchema Light where

192+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

158193

159194instance ToJSON Light where

160195 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

@@ -166,48 +201,78 @@ instance Arbitrary Light where

166201 , LightColor <$> arbitrary

167202 ]

168203

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

170222

171−#if MIN_VERSION_QuickCheck(2,8,2)

172−#else

173−instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where

174− arbitrary = Map.fromList <$> arbitrary

223+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

224+ deriving (Show, Generic)

175225

176−instance Arbitrary a => Arbitrary (IntMap a) where

177− arbitrary = IntMap.fromList <$> arbitrary

226+instance ToJSON ButtonImages where

227+ toJSON = toJSON . getButtonImages

178228

179−instance (Ord a, Arbitrary a) => Arbitrary (Set a) where

180− arbitrary = Set.fromList <$> arbitrary

181−#endif

229+instance ToSchema ButtonImages where

230+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

231+ declareSchemaBoundedEnumKeyMapping

182232

183−instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

184− arbitrary = HashMap.fromList <$> arbitrary

233+invalidButtonImagesToJSON :: ButtonImages -> Value

234+invalidButtonImagesToJSON = genericToJSON defaultOptions

185235

186−instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where

187− arbitrary = HashSet.fromList <$> arbitrary

236+instance Arbitrary ButtonImages where

237+ arbitrary = ButtonImages <$> arbitrary

188238

189−instance Arbitrary T.Text where

190− arbitrary = T.pack <$> arbitrary

239+-- ========================================================================

240+-- FreeForm (wraps a raw JSON Value)

241+-- ========================================================================

191242

192−instance Arbitrary TL.Text where

193− arbitrary = TL.pack <$> arbitrary

243+data FreeForm = FreeForm { jsonContent :: Map T.Text Value }

244+ deriving (Show, Generic)

194245

195−instance Arbitrary Day where

196− arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary

246+instance ToJSON FreeForm where

247+ toJSON = toJSON . jsonContent

197248

198−instance Arbitrary LocalTime where

199− arbitrary = LocalTime

200− <$> arbitrary

201− <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))

249+instance ToSchema FreeForm where

250+ declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty

251+ & type_ ?~ SwaggerObject

252+ & additionalProperties ?~ AdditionalPropertiesAllowed True

253+

254+instance Arbitrary FreeForm where

255+ arbitrary = (FreeForm . fromList) <$> genObj

256+ where

257+ genObj = listOf $ do

258+ k <- arbitrary

259+ v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]

260+ pure (k, v)

202261

203262instance Eq ZonedTime where

204263 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

205264

206−instance Arbitrary ZonedTime where

207− arbitrary = ZonedTime

208− <$> arbitrary

209− <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))

210−

211−instance Arbitrary UTCTime where

212− arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))

265+-- ========================================================================

266+-- Arbitrary instance for Data.Aeson.Value

267+-- ========================================================================

213268

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 ()

88import Prelude.Compat

1010import Control.Lens ((^.))

11−import Data.Aeson

12−import Data.Aeson.QQ

13−import Data.Char

14−import qualified Data.HashMap.Strict as HashMap

11+import Data.Aeson (Value)

1512import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

1613import Data.Proxy

1714import Data.Set (Set)

18−import qualified Data.Set as Set

1915import qualified Data.Text as Text

20−import GHC.Generics

2116

2217import Data.Swagger

2318import Data.Swagger.Declare

2419

20+import Data.Swagger.CommonTestTypes

2521import SpecCommon

2622import Test.Hspec

2723

24+import qualified Data.HashMap.Strict as HM

25+import Data.Time.LocalTime

26+

2827checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

2928checkToSchema proxy js = toSchema proxy <=> js

3029

@@ -78,8 +77,10 @@ spec = do

7877 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON

7978 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON

8079 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON

80+ context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON

8181 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON

8282 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

83+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

8384 context "Sum types" $ do

8485 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON

8586 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON

@@ -95,6 +96,7 @@ spec = do

9596 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]

9697 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

9798 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

99+ context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]

98100 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

99101 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []

100102 describe "Inlining Schemas" $ do

@@ -103,547 +105,10 @@ spec = do

103105 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

104106 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

105107 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

106112

107113main :: IO ()

108114main = 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

1010import Control.Lens

1111

1212import Data.Aeson

13−import Data.Aeson.QQ

13+import Data.Aeson.QQ.Simple

1414import Data.HashMap.Strict (HashMap)

15−import qualified Data.Set as Set

15+import qualified Data.HashSet.InsOrd as InsOrdHS

1616import Data.Text (Text)

1717

1818import Data.Swagger

@@ -37,11 +37,14 @@ spec = do

3737 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON

3838 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON

3939 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON

40+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON

4041 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

4142 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

4243 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

4344 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

4445 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

47+ describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

4548 describe "Swagger Object" $ do

4649 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

4750 context "PetStore Example" $

@@ -125,7 +128,7 @@ licenseExampleJSON = [aesonQQ|

125128

126129operationExample :: Operation

127130operationExample = mempty

128− & tags .~ Set.fromList ["pet"]

131+ & tags .~ InsOrdHS.fromList ["pet"]

129132 & summary ?~ "Updates a pet in the store with form data"

130133 & description ?~ ""

131134 & operationId ?~ "updatePetWithForm"

@@ -156,7 +159,7 @@ operationExample = mempty

156159 stringSchema :: ParamLocation -> ParamOtherSchema

157160 stringSchema loc = mempty

158161 & in_ .~ loc

159− & type_ .~ SwaggerString

162+ & type_ ?~ SwaggerString

160163

161164operationExampleJSON :: Value

162165operationExampleJSON = [aesonQQ|

@@ -222,7 +225,7 @@ operationExampleJSON = [aesonQQ|

222225

223226schemaPrimitiveExample :: Schema

224227schemaPrimitiveExample = mempty

225− & type_ .~ SwaggerString

228+ & type_ ?~ SwaggerString

226229 & format ?~ "email"

227230

228231schemaPrimitiveExampleJSON :: Value

@@ -235,14 +238,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

235238

236239schemaSimpleModelExample :: Schema

237240schemaSimpleModelExample = mempty

238− & type_ .~ SwaggerObject

241+ & type_ ?~ SwaggerObject

239242 & required .~ [ "name" ]

240243 & properties .~

241− [ ("name", Inline (mempty & type_ .~ SwaggerString))

244+ [ ("name", Inline (mempty & type_ ?~ SwaggerString))

242245 , ("address", Ref (Reference "Address"))

243246 , ("age", Inline $ mempty

244247 & minimum_ ?~ 0

245− & type_ .~ SwaggerInteger

248+ & type_ ?~ SwaggerInteger

246249 & format ?~ "int32" ) ]

247250

248251schemaSimpleModelExampleJSON :: Value

@@ -270,8 +273,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

270273

271274schemaModelDictExample :: Schema

272275schemaModelDictExample = mempty

273− & type_ .~ SwaggerObject

274− & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)

276+ & type_ ?~ SwaggerObject

277+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

275278

276279schemaModelDictExampleJSON :: Value

277280schemaModelDictExampleJSON = [aesonQQ|

@@ -283,15 +286,28 @@ schemaModelDictExampleJSON = [aesonQQ|

283286}

284287|]

285288

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+

286302schemaWithExampleExample :: Schema

287303schemaWithExampleExample = mempty

288− & type_ .~ SwaggerObject

304+ & type_ ?~ SwaggerObject

289305 & properties .~

290306 [ ("id", Inline $ mempty

291− & type_ .~ SwaggerInteger

307+ & type_ ?~ SwaggerInteger

292308 & format ?~ "int64" )

293309 , ("name", Inline $ mempty

294− & type_ .~ SwaggerString) ]

310+ & type_ ?~ SwaggerString) ]

295311 & required .~ [ "name" ]

296312 & example ?~ [aesonQQ|

297313 {

@@ -330,19 +346,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

330346definitionsExample :: HashMap Text Schema

331347definitionsExample =

332348 [ ("Category", mempty

333− & type_ .~ SwaggerObject

349+ & type_ ?~ SwaggerObject

334350 & properties .~

335351 [ ("id", Inline $ mempty

336− & type_ .~ SwaggerInteger

352+ & type_ ?~ SwaggerInteger

337353 & format ?~ "int64")

338− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

354+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

339355 , ("Tag", mempty

340− & type_ .~ SwaggerObject

356+ & type_ ?~ SwaggerObject

341357 & properties .~

342358 [ ("id", Inline $ mempty

343− & type_ .~ SwaggerInteger

359+ & type_ ?~ SwaggerInteger

344360 & format ?~ "int64")

345− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

361+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

346362

347363definitionsExampleJSON :: Value

348364definitionsExampleJSON = [aesonQQ|

@@ -386,7 +402,7 @@ paramsDefinitionExample =

386402 & required ?~ True

387403 & schema .~ ParamOther (mempty

388404 & in_ .~ ParamQuery

389− & type_ .~ SwaggerInteger

405+ & type_ ?~ SwaggerInteger

390406 & format ?~ "int32" ))

391407 , ("limitParam", mempty

392408 & name .~ "limit"

@@ -394,7 +410,7 @@ paramsDefinitionExample =

394410 & required ?~ True

395411 & schema .~ ParamOther (mempty

396412 & in_ .~ ParamQuery

397− & type_ .~ SwaggerInteger

413+ & type_ ?~ SwaggerInteger

398414 & format ?~ "int32" )) ]

399415

400416paramsDefinitionExampleJSON :: Value

@@ -444,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

444460-- Responses Definition object

445461-- =======================================================================

446462

447−securityDefinitionsExample :: HashMap Text SecurityScheme

448−securityDefinitionsExample =

463+securityDefinitionsExample :: SecurityDefinitions

464+securityDefinitionsExample = SecurityDefinitions

449465 [ ("api_key", SecurityScheme

450466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

451467 , _securitySchemeDescription = Nothing })

@@ -477,6 +493,46 @@ securityDefinitionsExampleJSON = [aesonQQ|

477493}

478494|]

479495

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+

480536-- =======================================================================

481537-- Swagger object

482538-- =======================================================================

@@ -495,7 +551,7 @@ swaggerExample = mempty

495551 & at 200 ?~ Inline (mempty

496552 & description .~ "OK"

497553 & schema ?~ Inline (mempty

498− & type_ .~ SwaggerObject

554+ & type_ ?~ SwaggerObject

499555 & example ?~ [aesonQQ|

500556 {

501557 "created": 100,

@@ -504,9 +560,9 @@ swaggerExample = mempty

504560 & description ?~ "This is some real Todo right here"

505561 & properties .~

506562 [ ("created", Inline $ mempty

507− & type_ .~ SwaggerInteger

563+ & type_ ?~ SwaggerInteger

508564 & format ?~ "int32")

509− , ("description", Inline (mempty & type_ .~ SwaggerString))]))

565+ , ("description", Inline (mempty & type_ ?~ SwaggerString))]))

510566 & produces ?~ MimeList [ "application/json" ]

511567 & parameters .~

512568 [ Inline $ mempty

@@ -515,8 +571,8 @@ swaggerExample = mempty

515571 & description ?~ "TodoId param"

516572 & schema .~ ParamOther (mempty

517573 & in_ .~ ParamPath

518− & type_ .~ SwaggerString ) ]

519− & tags .~ Set.fromList [ "todo" ] ))

574+ & type_ ?~ SwaggerString ) ]

575+ & tags .~ InsOrdHS.fromList [ "todo" ] ))

520576

521577swaggerExampleJSON :: Value

522578swaggerExampleJSON = [aesonQQ|

@@ -1614,3 +1670,33 @@ petstoreExampleJSON = [aesonQQ|

16141670 }

16151671}

16161672|]

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

3+import Build_doctests (flags, pkgs, module_sources)

4+import Data.Foldable (traverse_)

5+import Test.DocTest

7+main :: IO ()

8+main = do

9+ traverse_ putStrLn args

10+ doctest args

11+ where

12+ args = flags ++ pkgs ++ module_sources