master..af164c1 · typeable/swagger2

git.iko.soy/typeable/swagger2

38 files changed+1133−3402

unifiedsplit

.ghci+1−2 .gitignore−2 .travis.yml+70−150 CHANGELOG.md−130 LICENSE+1−1 README.md+1−3 Setup.hs−31 cabal.project−2 examples/hackage.hs+1−15 hackage-docs.sh−78 src/Data/Swagger.hs+3−65 src/Data/Swagger/Declare.hs+5−77 src/Data/Swagger/Internal.hs+31−148 src/Data/Swagger/Internal/AesonUtils.hs+9−19 src/Data/Swagger/Internal/ParamSchema.hs+26−95 src/Data/Swagger/Internal/Schema.hs+95−238 src/Data/Swagger/Internal/Schema/Validation.hs+78−263 src/Data/Swagger/Internal/TypeShape.hs−66 src/Data/Swagger/Internal/Utils.hs+1 src/Data/Swagger/Lens.hs+6−16 src/Data/Swagger/Operation.hs+12−10 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+1−10 src/Data/Swagger/SchemaOptions.hs−29 stack-ghc-8.0.yaml+3 stack-lts-2.yaml+8 stack.yaml+4−6 swagger2.cabal+45−97 test/Data/Swagger/CommonTestTypes.hs−679 test/Data/Swagger/ParamSchemaSpec.hs+84−8 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs+65−130 test/Data/Swagger/SchemaSpec.hs+547−12 test/Data/SwaggerSpec.hs+28−114 test/DocTest.hs+8 test/doctests.hs−12

.ghci+1−2

@@ -1,2 +1 @@

1−:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/autogen/cabal_macros.h -optP-I -optPinclude

2−:set -hide-package base-compat-0.10.4

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

.gitignore−2

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

11dist

2−dist-newstyle

3−.ghc.environment.*

42cabal-dev

53*.o

64*.hi

.travis.yml+70−150

@@ -1,162 +1,82 @@

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

1+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis

92language: c

10−dist: xenial

11−git:

12− # whether to recursively clone submodules

13− submodules: false

14−branches:

15− only:

16− - master

3+sudo: false

175cache:

186 directories:

7+ - $HOME/.cabsnap

198 - $HOME/.cabal/packages

20− - $HOME/.cabal/store

2110before_cache:

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

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+

3014matrix:

3115 include:

32− - compiler: ghc-8.8.1

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

34− - compiler: ghc-8.6.5

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

36− - compiler: ghc-8.4.4

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

38− - compiler: ghc-8.2.2

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

40− - compiler: ghc-8.0.2

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

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+

4226before_install:

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

44− - WITHCOMPILER="-w $HC"

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

46− - HCPKG="$HC-pkg"

47− - unset CC

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

49− - CABALHOME=$HOME/.cabal

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

51− - TOP=$(pwd)

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

53− - echo $HCNUMVER

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

55− - set -o pipefail

56− - |

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

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

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

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

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

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

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

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

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

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

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

68− - cat .colorful.awk

69− - |

70− color_cabal_output () {

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

72− }

73− - echo text | color_cabal_output

27+ - unset CC

28+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/1.19.5/bin:$PATH

29+

7430install:

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

31+ - cabal --version

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

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

34+ then

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

36+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;

37+ fi

38+ - travis_retry cabal update -v

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

40+ - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt

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

42+

43+# check whether current requested install-plan matches cached package-db snapshot

44+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;

45+ then

46+ echo "cabal build-cache HIT";

47+ rm -rfv .ghc;

48+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;

49+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;

50+ else

51+ echo "cabal build-cache MISS";

52+ rm -rf $HOME/.cabsnap;

53+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;

54+ cabal install --only-dependencies --enable-tests --enable-benchmarks;

55+ fi

56+

57+# snapshot package-db on cache miss

58+ - if [ ! -d $HOME/.cabsnap ];

59+ then

60+ echo "snapshotting package-db to build-cache";

61+ mkdir $HOME/.cabsnap;

62+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;

63+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

64+ fi

65+

66+# Here starts the actual work to be performed for the package under test;

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

12668script:

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

69+ - if [ -f configure.ac ]; then autoreconf -i; fi

70+ - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging

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

72+ - cabal test

73+ - cabal check

74+ - cabal sdist # tests that a source-distribution can be generated

75+

76+# Check that the resulting source distribution can be built & installed.

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

78+# `cabal install --force-reinstalls dist/*-*.tar.gz`

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

80+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")

16081

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

16282# EOF

CHANGELOG.md−130

@@ -1,133 +1,3 @@

1−2.5

2−---

3−

4−Highlights:

5−- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));

6−- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));

7−- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));

8−

9−Fixes and minor changes:

10−- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));

11−- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));

12−- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));

13−

14−2.4

15−---

16−

17−- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5

18−- Tags aren't sorted

19− (see [#165](https://github.com/GetShopTV/swagger2/issues/165))

20−- Schema type is optional

21− (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))

22−- Take concrete 'Proxy' as argument

23− (see [#180](https://github.com/GetShopTV/swagger2/pull/180))

24−- GHC-8.8 preparations

25−

26−2.3.1.1

27−-------

28−

29−- Allow `network-3.0`

30−

31−2.3.1

32−-----

33−

34−- Add a quickcheck generator for aeson Values that match a swagger schema

35− (see [#162](https://github.com/GetShopTV/swagger2/pull/162))

36−- Add `ToParamSchema` instance for `SetCookie`

37− (see [#173](https://github.com/GetShopTV/swagger2/pull/173))

38−- Make nullary schemas valid

39− (see [#168](https://github.com/GetShopTV/swagger2/pull/168))

40−

41−2.3.0.1

42−-------

43−

44−- Support GHC-8.6

45−

46−2.3

47−---

48−

49−Major changes:

50−

51−- Add support for `additionalProperties` with `Bool` value (see [#159](https://github.com/GetShopTV/swagger2/pull/159));

52−- Add `ToSchema` `Object` instance (for aeson's `Object`) (see [`d72466a`](https://github.com/GetShopTV/swagger2/commit/d72466a));

53−

54−Dependencies and CI:

55−

56−- Aeson 1.4 (see [#158](https://github.com/GetShopTV/swagger2/pull/158));

57−- Update .travis.yml (see [#160](https://github.com/GetShopTV/swagger2/pull/160));

58−- Allow network 2.7 (see [#155](https://github.com/GetShopTV/swagger2/pull/155));

59−- Allow lens-4.17 (see [#161](https://github.com/GetShopTV/swagger2/pull/161));

60−

61−2.2.2

62−-----

63−

64−* Add `ToSchema Version` instance

65−* Use base-compat-batteries (0.10)

66−* PVP bounds

67−

68−2.2.1

69−-----

70−

71−* Add `Semigroup` instances

72−* GHC-8.4 compatibility

73−* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141))

74−* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142))

75−* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139))

76−* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132))

77−

78−2.2

79−---

80−

81−* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126));

82−* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126));

83−* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)):

84− * `genericNameSchema` — to give a custom schema `Generic`-based name;

85− * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s;

86− * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys;

87−* Add a few tests with invalid `Schema`.

88−

89−2.1.6

90−-----

91−

92−* Add `ToParamSchema` and `ToSchema` instances for `Fixed` (see [#121](https://github.com/GetShopTV/swagger2/pull/121)) and `Natural` (see [#123](https://github.com/GetShopTV/swagger2/pull/123));

93−* Fix instance for `NominalDiffTime` (see [#121](https://github.com/GetShopTV/swagger2/pull/121));

94−* Fix build for `aeson-1.2.2.0` (see [#125](https://github.com/GetShopTV/swagger2/pull/125)).

95−

96−2.1.5

97−-----

98−

99−* Type error by default when deriving Generic-based instances for mixed sum types (see [#118](https://github.com/GetShopTV/swagger2/pull/118));

100−* Adjust `allOf` to accept referenced schemas (see [#119](https://github.com/GetShopTV/swagger2/issues/119));

101−* Add instances for `Identity` (see [#116](https://github.com/GetShopTV/swagger2/pull/116));

102−* Add Gitter chat badge (see [#114](https://github.com/GetShopTV/swagger2/pull/114)).

103−

104−2.1.4.1

105−-------

106−

107−* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95), [#106](https://github.com/GetShopTV/swagger2/pull/106) and [#108](https://github.com/GetShopTV/swagger2/pull/108));

108−* Documentation corrections (see [#105](https://github.com/GetShopTV/swagger2/pull/105));

109−* Allow `generics-sop-0.3` (see [#102](https://github.com/GetShopTV/swagger2/pull/102));

110−* Fix `ToSchema` example in docs (see [#104](https://github.com/GetShopTV/swagger2/pull/104)).

111−

112−2.1.4

113−-----

114−

115−* Add `liftDeclare` (see [#100](https://github.com/GetShopTV/swagger2/pull/100));

116−* Add `MonadDeclare` instances for all monad transformers (see [#100](https://github.com/GetShopTV/swagger2/pull/100)).

117−

118−2.1.3

119−-----

120−

121−* Add [`UUID`](http://hackage.haskell.org/package/uuid-types/docs/Data-UUID-Types.html#t:UUID) instances (see [#81](https://github.com/GetShopTV/swagger2/pull/81)).

122−* Add [`TypeError`](https://hackage.haskell.org/package/base-4.9.0.0/docs/GHC-TypeLits.html#g:4) `ToSchema` and `ToParamSchema ByteString` instances (see [#78](https://github.com/GetShopTV/swagger2/pull/78))

123−* Improve documentation for generic sum type instance derivation (see [#75](https://github.com/GetShopTV/swagger2/pull/75))

124−* Compile warning free (see [#82](https://github.com/GetShopTV/swagger2/pull/82))

125−

126−2.1.2.1

127−-------

128−

129−* Bug fix previous release

130−

13112.1.2

1322---

1333

LICENSE+1−1

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

22All rights reserved.

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

README.md+1−3

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

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)

4−

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

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

75[![Stackage LTS](http://stackage.org/package/swagger2/badge/lts)](http://stackage.org/lts/package/swagger2)

@@ -13,7 +11,7 @@ The original Swagger 2.0 specification is available at http://swagger.io/specifi

1311

1412## Usage

1513

16−This library is intended to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.

14+This library is inteded to be used for decoding and encoding Swagger 2.0 API specifications as well as manipulating them.

1715

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

1917

Setup.hs−31

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

1−{-# LANGUAGE CPP #-}

2−{-# OPTIONS_GHC -Wall #-}

3−module Main (main) where

4−

5−#ifndef MIN_VERSION_cabal_doctest

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

7−#endif

8−

9−#if MIN_VERSION_cabal_doctest(1,0,0)

10−

11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12−main :: IO ()

13−main = defaultMainWithDoctests "doctests"

14−

15−#else

16−

17−#ifdef MIN_VERSION_Cabal

18−-- If the macro is defined, we have new cabal-install,

19−-- but for some reason we don't have cabal-doctest in package-db

20−--

21−-- Probably we are running cabal sdist, when otherwise using new-build

22−-- workflow

23−#warning You are configuring this package without cabal-doctest installed. \

24− The doctests test-suite will not work as a result. \

25− To fix this, install cabal-doctest before configuring.

26−#endif

27−

281import Distribution.Simple

29−

30−main :: IO ()

312main = defaultMain

32−

33−#endif

cabal.projectdeleted−2

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

1−packages: .

2−tests: true

examples/hackage.hs+1−15

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

2020data UserSummary = UserSummary

2121 { summaryUsername :: Username

2222 , summaryUserid :: Int

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−

23+ } deriving (Generic, ToSchema)

3824

3925type Group = Text

4026

hackage-docs.shdeleted−78

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

1−#!/bin/bash

2−set -e

3−

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

5−

6−if [ "$#" -ne 1 ]; then

7− echo "Usage: scripts/hackage-docs.sh HACKAGE_USER"

8− exit 1

9−fi

10−

11−user=$1

12−

13−cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit)

14−if [ ! -f "$cabal_file" ]; then

15− echo "Run this script in the top-level package directory"

16− exit 1

17−fi

18−

19−pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file")

20−ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file")

21−

22−if [ -z "$pkg" ]; then

23− echo "Unable to determine package name"

24− exit 1

25−fi

26−

27−if [ -z "$ver" ]; then

28− echo "Unable to determine package version"

29− exit 1

30−fi

31−

32−echo "Detected package: $pkg-$ver"

33−

34−dir=$(mktemp -d build-docs.XXXXXX)

35−trap 'rm -r "$dir"' EXIT

36−

37−export PATH=$(stack path --bin-path)

38−

39−ghc --version

40−cabal --version

41−stack --version

42−

43−if haddock --hyperlinked-source >/dev/null

44−then

45− echo "Using fancy hyperlinked source"

46− HYPERLINK_FLAG="--haddock-option=--hyperlinked-source"

47−else

48− echo "Using boring hyperlinked source"

49− HYPERLINK_FLAG="--hyperlink-source"

50−fi

51−

52−# Cabal dist in temporary location

53−builddir=$dir/dist

54−

55−# Build dependencies haddocks with stack, so we get links

56−stack haddock --only-dependencies

57−

58−# Configure using stack databases

59−snapshotpkgdb=$(stack path --snapshot-pkg-db)

60−localpkgdb=$(stack path --local-pkg-db)

61−cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb

62−

63−# Build Hadckage compatible docs

64−cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version'

65−

66−# Copy into right directory

67−cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs

68−

69−# Tar and gzip

70−tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs

71−

72−# Upload

73−curl -X PUT \

74− -H 'Content-Type: application/x-tar' \

75− -H 'Content-Encoding: gzip' \

76− -u "$user" \

77− --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \

78− "https://hackage.haskell.org/package/$pkg-$ver/docs"

src/Data/Swagger.hs+3−65

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

1−{-# LANGUAGE CPP #-}

21-- |

32-- Module: Data.Swagger

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

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

3130

3231 -- * Re-exports

3332 module Data.Swagger.Lens,

34− module Data.Swagger.Optics,

3533 module Data.Swagger.Operation,

3634 module Data.Swagger.ParamSchema,

3735 module Data.Swagger.Schema,

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

7876 SwaggerItems(..),

7977 Xml(..),

8078 Pattern,

81− AdditionalProperties(..),

8279

8380 -- ** Responses

8481 Responses(..),

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

8986 SecurityScheme(..),

9087 SecuritySchemeType(..),

9188 SecurityRequirement(..),

92− SecurityDefinitions(..),

9389

9490 -- *** API key

9591 ApiKeyParams(..),

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

114110) where

115111

116112import Data.Swagger.Lens

117−import Data.Swagger.Optics ()

118113import Data.Swagger.Operation

119114import Data.Swagger.ParamSchema

120115import Data.Swagger.Schema

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

178173

179174-- $lens

180175--

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

182−--

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

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

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

186179--

187180-- >>> :{

188181-- encode $ (mempty :: Swagger)

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

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

190183-- & paths .~

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

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

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

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

210203-- >>> :{

211204-- encode $ (mempty :: Schema)

212−-- & type_ ?~ SwaggerBoolean

205+-- & type_ .~ SwaggerBoolean

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

214207-- :}

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

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

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

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

220213--

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

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

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

223216--

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

@@ -279,61 +272,6 @@ import Data.Swagger.Internal

279272-- "{\"age\":28,\"name\":\"David\"}"

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

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

282−--

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

284−-- schema for basic enums like

285−--

286−-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic

287−-- >>> instance ToSchema SampleEnum

288−-- >>> instance ToJSON SampleEnum

289−--

290−-- and for sum types that have constructors with values

291−--

292−-- >>> data SampleSumType = ChoiceInt Int | ChoiceString String deriving Generic

293−-- >>> instance ToSchema SampleSumType

294−-- >>> instance ToJSON SampleSumType

295−--

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

297−--

298−#if __GLASGOW_HASKELL__ < 800

299−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic

300−-- >>> instance ToSchema BadMixedType

301−-- ...

302−-- ... error:

303−-- ... • No instance for (Data.Swagger.Internal.TypeShape.CannotDeriveSchemaForMixedSumType

304−-- ... BadMixedType)

305−-- ... arising from a use of ‘Data.Swagger.Internal.Schema.$dmdeclareNamedSchema’

306−-- ... • In the expression:

307−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType

308−-- ... In an equation for ‘declareNamedSchema’:

309−-- ... declareNamedSchema

310−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType

311−-- ... In the instance declaration for ‘ToSchema BadMixedType’

312−#else

313−-- >>> data BadMixedType = ChoiceBool Bool | JustTag deriving Generic

314−-- >>> instance ToSchema BadMixedType

315−-- ...

316−-- ... error:

317−-- ... • Cannot derive Generic-based Swagger Schema for BadMixedType

318−-- ... BadMixedType is a mixed sum type (has both unit and non-unit constructors).

319−-- ... Swagger does not have a good representation for these types.

320−-- ... Use genericDeclareNamedSchemaUnrestricted if you want to derive schema

321−-- ... that matches aeson's Generic-based toJSON,

322−-- ... but that's not supported by some Swagger tools.

323−-- ... • In the expression:

324−-- ... Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType

325−-- ... In an equation for ‘declareNamedSchema’:

326−-- ... declareNamedSchema

327−-- ... = Data.Swagger.Internal.Schema.$dmdeclareNamedSchema @BadMixedType

328−-- ... In the instance declaration for ‘ToSchema BadMixedType’

329−#endif

330−--

331−-- We can use 'genericDeclareNamedSchemaUnrestricted' to try our best to represent this type as a Swagger Schema and match 'ToJSON':

332−--

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

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

335−-- >>> instance ToJSON BadMixedType

336−--

337275

338276-- $manipulation

339277-- Sometimes you have to work with an imported or generated @'Swagger'@.

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

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

22{-# LANGUAGE FlexibleInstances #-}

33{-# LANGUAGE FunctionalDependencies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE UndecidableInstances #-}

65-- |

76-- Module: Data.Swagger.Declare

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

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

1514import Prelude.Compat

1615

1716import Control.Monad

18−import Control.Monad.Cont (ContT)

19−import Control.Monad.List (ListT)

20−import Control.Monad.Reader (ReaderT)

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

3118import Data.Functor.Identity

19+import Data.Monoid

3220

3321-- | A declare monad transformer parametrized by:

3422--

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

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

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

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

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

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

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

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

5442

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

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

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

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

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

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

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

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

6149

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

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

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

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

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

9179

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−

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

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

10182looks f = f <$> look

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

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

145126undeclare = runIdentity . undeclareT

146127

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+31−148

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

2929import Data.Aeson

3030import qualified Data.Aeson.Types as JSON

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

32−import Data.Hashable (Hashable)

3332import qualified Data.HashMap.Strict as HashMap

34−import Data.HashSet.InsOrd (InsOrdHashSet)

3533import Data.Map (Map)

3634import qualified Data.Map as Map

37−import Data.Monoid (Monoid (..))

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

35+import Data.Monoid

3936import Data.Scientific (Scientific)

37+import Data.Set (Set)

4038import Data.String (IsString(..))

4139import Data.Text (Text)

4240import qualified Data.Text as Text

4341import GHC.Generics (Generic)

44−import Network.Socket (HostName, PortNumber)

42+import Network (HostName, PortNumber)

4543import Network.HTTP.Media (MediaType)

4644import Text.Read (readMaybe)

4745

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

6664#define DEFINE_TOENCODING

6765#endif

6866

69−-- $setup

70−-- >>> :seti -XDataKinds

71−-- >>> import Data.Aeson

72−

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

7468type Definitions = InsOrdHashMap Text

7569

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

117111 , _swaggerResponses :: Definitions Response

118112

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

120− , _swaggerSecurityDefinitions :: SecurityDefinitions

114+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme

121115

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

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

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

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

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

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

133− , _swaggerTags :: InsOrdHashSet Tag

127+ , _swaggerTags :: Set Tag

134128

135129 -- | Additional external documentation.

136130 , _swaggerExternalDocs :: Maybe ExternalDocs

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

252246data Operation = Operation

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

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

255− _operationTags :: InsOrdHashSet TagName

249+ _operationTags :: Set TagName

256250

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

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

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

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

310304

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

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

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

313307

314308mimeListConstr :: Constr

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

@@ -464,7 +458,7 @@ deriving instance Show (SwaggerType t)

464458swaggerTypeConstr :: Data (SwaggerType t) => SwaggerType t -> Constr

465459swaggerTypeConstr t = mkConstr (dataTypeOf t) (show t) [] Prefix

466460

467−swaggerTypeDataType :: {- Data (SwaggerType t) => -} SwaggerType t -> DataType

461+swaggerTypeDataType :: Data (SwaggerType t) => SwaggerType t -> DataType

468462swaggerTypeDataType _ = mkDataType "Data.Swagger.SwaggerType" swaggerTypeConstrs

469463

470464swaggerCommonTypes :: [SwaggerType k]

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

560554 , _schemaDescription :: Maybe Text

561555 , _schemaRequired :: [ParamName]

562556

563− , _schemaAllOf :: Maybe [Referenced Schema]

557+ , _schemaAllOf :: Maybe [Schema]

564558 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

565− , _schemaAdditionalProperties :: Maybe AdditionalProperties

559+ , _schemaAdditionalProperties :: Maybe (Referenced Schema)

566560

567561 , _schemaDiscriminator :: Maybe Text

568562 , _schemaReadOnly :: Maybe Bool

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

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

595589 _paramSchemaDefault :: Maybe Value

596590

597− , _paramSchemaType :: Maybe (SwaggerType t)

591+ , _paramSchemaType :: SwaggerType t

598592 , _paramSchemaFormat :: Maybe Format

599593 , _paramSchemaItems :: Maybe (SwaggerItems t)

600594 , _paramSchemaMaximum :: Maybe Scientific

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

611605 , _paramSchemaMultipleOf :: Maybe Scientific

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

613607

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

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

615609

616610data Xml = Xml

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

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

755749 , _securitySchemeDescription :: Maybe Text

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

757751

758−

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

760−-- In other case returns first security scheme

761−mergeSecurityScheme :: SecurityScheme -> SecurityScheme -> SecurityScheme

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

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

764− = if flow1 == flow2 then

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

766− else

767− s1

768−mergeSecurityScheme s1 _ = s1

769−

770−newtype SecurityDefinitions

771− = SecurityDefinitions (Definitions SecurityScheme)

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

773−

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

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

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

777755newtype SecurityRequirement = SecurityRequirement

778756 { getSecurityRequirement :: InsOrdHashMap Text [Text]

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

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

780758

781759-- | Tag name.

782760type TagName = Text

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

795773 , _tagExternalDocs :: Maybe ExternalDocs

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

797775

798−instance Hashable Tag

799−

800776instance IsString Tag where

801777 fromString s = Tag (fromString s) Nothing Nothing

802778

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

810786 , _externalDocsUrl :: URL

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

812788

813−instance Hashable ExternalDocs

814−

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

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

817791newtype Reference = Reference { getReference :: Text }

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

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

826800 fromString = Inline . fromString

827801

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

829−

830−data AdditionalProperties

831− = AdditionalPropertiesAllowed Bool

832− | AdditionalPropertiesSchema (Referenced Schema)

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

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

834803

835804-- =======================================================================

836805-- Monoid instances

837806-- =======================================================================

838807

839−instance Semigroup Swagger where

840− (<>) = genericMappend

841808instance Monoid Swagger where

842809 mempty = genericMempty

843− mappend = (<>)

810+ mappend = genericMappend

844811

845−instance Semigroup Info where

846− (<>) = genericMappend

847812instance Monoid Info where

848813 mempty = genericMempty

849− mappend = (<>)

814+ mappend = genericMappend

850815

851−instance Semigroup Contact where

852− (<>) = genericMappend

853816instance Monoid Contact where

854817 mempty = genericMempty

855− mappend = (<>)

818+ mappend = genericMappend

856819

857−instance Semigroup PathItem where

858− (<>) = genericMappend

859820instance Monoid PathItem where

860821 mempty = genericMempty

861− mappend = (<>)

822+ mappend = genericMappend

862823

863−instance Semigroup Schema where

864− (<>) = genericMappend

865824instance Monoid Schema where

866825 mempty = genericMempty

867− mappend = (<>)

826+ mappend = genericMappend

868827

869−instance Semigroup (ParamSchema t) where

870− (<>) = genericMappend

871828instance Monoid (ParamSchema t) where

872829 mempty = genericMempty

873− mappend = (<>)

830+ mappend = genericMappend

874831

875−instance Semigroup Param where

876− (<>) = genericMappend

877832instance Monoid Param where

878833 mempty = genericMempty

879− mappend = (<>)

834+ mappend = genericMappend

880835

881−instance Semigroup ParamOtherSchema where

882− (<>) = genericMappend

883836instance Monoid ParamOtherSchema where

884837 mempty = genericMempty

885− mappend = (<>)

838+ mappend = genericMappend

886839

887−instance Semigroup Header where

888− (<>) = genericMappend

889840instance Monoid Header where

890841 mempty = genericMempty

891− mappend = (<>)

842+ mappend = genericMappend

892843

893−instance Semigroup Responses where

894− (<>) = genericMappend

895844instance Monoid Responses where

896845 mempty = genericMempty

897− mappend = (<>)

846+ mappend = genericMappend

898847

899−instance Semigroup Response where

900− (<>) = genericMappend

901848instance Monoid Response where

902849 mempty = genericMempty

903− mappend = (<>)

850+ mappend = genericMappend

904851

905−instance Semigroup ExternalDocs where

906− (<>) = genericMappend

907852instance Monoid ExternalDocs where

908853 mempty = genericMempty

909− mappend = (<>)

854+ mappend = genericMappend

910855

911−instance Semigroup Operation where

912− (<>) = genericMappend

913856instance Monoid Operation where

914857 mempty = genericMempty

915− mappend = (<>)

858+ mappend = genericMappend

916859

917−instance Semigroup Example where

918− (<>) = genericMappend

919860instance Monoid Example where

920861 mempty = genericMempty

921− mappend = (<>)

922−

923−instance Semigroup SecurityScheme where

924− (<>) = mergeSecurityScheme

925−

926−instance Semigroup SecurityDefinitions where

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

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

929−

930−instance Monoid SecurityDefinitions where

931− mempty = SecurityDefinitions $ InsOrdHashMap.empty

932− mappend = (<>)

862+ mappend = genericMappend

933863

934864-- =======================================================================

935865-- SwaggerMonoid helper instances

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

945875instance SwaggerMonoid Response

946876instance SwaggerMonoid ExternalDocs

947877instance SwaggerMonoid Operation

948−instance SwaggerMonoid SecurityDefinitions

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

950878

951879instance SwaggerMonoid MimeList

952880deriving instance SwaggerMonoid URL

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

965893

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

967895 swaggerMempty = Inline mempty

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

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

969897 swaggerMappend _ y = y

970898

971899instance SwaggerMonoid ParamAnySchema where

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

10881016 toJSON = sopSwaggerGenericToJSON

10891017 DEFINE_TOENCODING

10901018

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

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

1093−--

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

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

1096−--

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

10981020 toJSON (SwaggerItemsPrimitive fmt schema) = object

10991021 [ "collectionFormat" .= fmt

11001022 , "items" .= schema ]

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

1102− toJSON (SwaggerItemsArray []) = object

1103− [ "items" .= object []

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

1105− , "example" .= Array mempty

1106− ]

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

11081025

11091026instance ToJSON Host where

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

11461063instance ToJSON Example where

11471064 toJSON = toJSON . Map.mapKeys show . getExample

11481065

1149−instance ToJSON SecurityDefinitions where

1150− toJSON (SecurityDefinitions sd) = toJSON sd

1151−

11521066instance ToJSON Reference where

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

11541068

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

11821096 toJSON = sopSwaggerGenericToJSONWithOpts $

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

11841098

1185−instance ToJSON AdditionalProperties where

1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b

1187− toJSON (AdditionalPropertiesSchema s) = toJSON s

1188−

11891099-- =======================================================================

11901100-- Manual FromJSON instances

11911101-- =======================================================================

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

12231133 parseJSON = sopSwaggerGenericParseJSON

12241134

12251135instance FromJSON Schema where

1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON

1227− where nullaryCleanup :: Schema -> Schema

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

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

1230− then s { _schemaExample = Nothing

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

1232− else s

1136+ parseJSON = sopSwaggerGenericParseJSON

12331137

12341138instance FromJSON Header where

12351139 parseJSON = sopSwaggerGenericParseJSON

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

12441148 <$> o .:? "collectionFormat"

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

12461150

1247−-- |

1248−--

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

1250−-- Just (SwaggerItemsArray [])

1251−--

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

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

1254−--

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

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

1257−--

12581151instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1259− parseJSON js@(Object obj)

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

1261− | otherwise = SwaggerItemsObject <$> parseJSON js

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

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

12631154 parseJSON _ = empty

12641155

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

13101201instance FromJSON PathItem where

13111202 parseJSON = sopSwaggerGenericParseJSON

13121203

1313−instance FromJSON SecurityDefinitions where

1314− parseJSON js = SecurityDefinitions <$> parseJSON js

1315−

13161204instance FromJSON Reference where

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

13181206 parseJSON _ = empty

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

13631251instance FromJSON (ParamSchema 'SwaggerKindSchema) where

13641252 parseJSON = sopSwaggerGenericParseJSON

13651253

1366−instance FromJSON AdditionalProperties where

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

1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js

1369−

13701254-------------------------------------------------------------------------------

13711255-- TH splices

13721256-------------------------------------------------------------------------------

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

14241308instance AesonDefaultValue MimeList where defaultValue = Just mempty

14251309instance AesonDefaultValue Info

14261310instance AesonDefaultValue ParamLocation

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

src/Data/Swagger/Internal/AesonUtils.hs+9−19

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

4444import qualified Data.HashMap.Strict as HM

4545import qualified Data.Set as Set

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

47−import qualified Data.HashSet.InsOrd as InsOrdHS

4847

4948#if MIN_VERSION_aeson(0,10,0)

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

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

5151#endif

5252

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

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

6868makeLenses ''SwaggerAesonOptions

6969

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

71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

71+ swaggerAesonOptions :: proxy a -> SwaggerAesonOptions

7272

7373 -- So far we use only default definitions

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

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

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

7676

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

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

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

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

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

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

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

9190

9291-------------------------------------------------------------------------------

@@ -102,7 +101,8 @@ instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just

102101-- * possible to merge sub-object

103102sopSwaggerGenericToJSON

104103 :: forall a xs.

105− ( HasDatatypeInfo a

104+ ( Generic a

105+ , HasDatatypeInfo a

106106 , HasSwaggerAesonOptions a

107107 , All2 ToJSON (Code a)

108108 , All2 Eq (Code a)

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

146146 -> DatatypeInfo '[xs]

147147 -> POP Maybe '[xs]

148148 -> [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

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

153−#endif

154150 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

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

156152

@@ -194,7 +190,8 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

194190

195191sopSwaggerGenericParseJSON

196192 :: forall a xs.

197− ( HasDatatypeInfo a

193+ ( Generic a

194+ , HasDatatypeInfo a

198195 , HasSwaggerAesonOptions a

199196 , All2 FromJSON (Code a)

200197 , All2 Eq (Code a)

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

226223 -> DatatypeInfo '[xs]

227224 -> POP Maybe '[xs]

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

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

233−#endif

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

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

236229

@@ -277,7 +270,8 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go

277270

278271sopSwaggerGenericToEncoding

279272 :: forall a xs.

280− ( HasDatatypeInfo a

273+ ( Generic a

274+ , HasDatatypeInfo a

281275 , HasSwaggerAesonOptions a

282276 , All2 ToJSON (Code a)

283277 , All2 Eq (Code a)

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

302296 -> DatatypeInfo '[xs]

303297 -> POP Maybe '[xs]

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

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

309−#endif

310300 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

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

312302

src/Data/Swagger/Internal/ParamSchema.hs+26−95

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE DefaultSignatures #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

@@ -8,21 +7,13 @@

87{-# LANGUAGE PackageImports #-}

98{-# LANGUAGE PolyKinds #-}

109{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

1210{-# LANGUAGE TypeOperators #-}

1311{-# LANGUAGE TypeSynonymInstances #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−#if __GLASGOW_HASKELL__ >= 800

16−-- Generic a is redundant in ToParamSchema a default imple

17−{-# OPTIONS_GHC -Wno-redundant-constraints #-}

18−-- For TypeErrors

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

20−#endif

2112#include "overlapping-compat.h"

2213module Data.Swagger.Internal.ParamSchema where

2314

2415import Control.Lens

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

16+import Data.Aeson

2617import Data.Proxy

2718import GHC.Generics

2819

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

3122import Data.Monoid

3223import Data.Set (Set)

3324import Data.Scientific

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

3525import qualified Data.Text as T

3626import qualified Data.Text.Lazy as TL

3727import Data.Time

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

3929import qualified Data.Vector.Primitive as VP

4030import qualified Data.Vector.Storable as VS

4131import qualified Data.Vector.Unboxed as VU

42−import Data.Version (Version)

43−import Numeric.Natural.Compat (Natural)

4432import Data.Word

45−import Data.UUID.Types (UUID)

46−import Web.Cookie (SetCookie)

4733

4834import Data.Swagger.Internal

4935import Data.Swagger.Lens

5036import Data.Swagger.SchemaOptions

5137

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−

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

6039binaryParamSchema :: ParamSchema t

6140binaryParamSchema = mempty

62− & type_ ?~ SwaggerString

41+ & type_ .~ SwaggerString

6342 & format ?~ "binary"

6443

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

6645byteParamSchema :: ParamSchema t

6746byteParamSchema = mempty

68− & type_ ?~ SwaggerString

47+ & type_ .~ SwaggerString

6948 & format ?~ "byte"

7049

7150-- | Default schema for password string.

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

7352passwordParamSchema :: ParamSchema t

7453passwordParamSchema = mempty

75− & type_ ?~ SwaggerString

54+ & type_ .~ SwaggerString

7655 & format ?~ "password"

7756

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

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

8766-- data Direction = Up | Down

8867--

8968-- instance ToParamSchema Direction where

90−-- toParamSchema _ = mempty

91−-- & type_ ?~ SwaggerString

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

69+-- toParamSchema = mempty

70+-- & type_ .~ SwaggerString

71+-- & enum_ .~ [ \"Up\", \"Down\" ]

9372-- @

9473--

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

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

11594 --

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

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

118− toParamSchema :: Proxy a -> ParamSchema t

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

97+ toParamSchema :: proxy a -> ParamSchema t

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

12099 toParamSchema = genericToParamSchema defaultSchemaOptions

121100

122101instance OVERLAPPING_ ToParamSchema String where

123− toParamSchema _ = mempty & type_ ?~ SwaggerString

102+ toParamSchema _ = mempty & type_ .~ SwaggerString

124103

125104instance ToParamSchema Bool where

126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

105+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean

127106

128107instance ToParamSchema Integer where

129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger

130−

131−instance ToParamSchema Natural where

132− toParamSchema _ = mempty

133− & type_ ?~ SwaggerInteger

134− & minimum_ ?~ 0

135− & exclusiveMinimum ?~ False

108+ toParamSchema _ = mempty & type_ .~ SwaggerInteger

136109

137110instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral

138111instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral

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

154127--

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

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

157−toParamSchemaBoundedIntegral :: forall a t. (Bounded a, Integral a) => Proxy a -> ParamSchema t

130+toParamSchemaBoundedIntegral :: forall proxy a t. (Bounded a, Integral a) => proxy a -> ParamSchema t

158131toParamSchemaBoundedIntegral _ = mempty

159− & type_ ?~ SwaggerInteger

132+ & type_ .~ SwaggerInteger

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

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

162135

163136instance ToParamSchema Char where

164137 toParamSchema _ = mempty

165− & type_ ?~ SwaggerString

138+ & type_ .~ SwaggerString

166139 & maxLength ?~ 1

167140 & minLength ?~ 1

168141

169142instance ToParamSchema Scientific where

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

143+ toParamSchema _ = mempty & type_ .~ SwaggerNumber

176144

177145instance ToParamSchema Double where

178146 toParamSchema _ = mempty

179− & type_ ?~ SwaggerNumber

147+ & type_ .~ SwaggerNumber

180148 & format ?~ "double"

181149

182150instance ToParamSchema Float where

183151 toParamSchema _ = mempty

184− & type_ ?~ SwaggerNumber

152+ & type_ .~ SwaggerNumber

185153 & format ?~ "float"

186154

187155timeParamSchema :: String -> ParamSchema t

188156timeParamSchema fmt = mempty

189− & type_ ?~ SwaggerString

157+ & type_ .~ SwaggerString

190158 & format ?~ T.pack fmt

191159

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

193161instance ToParamSchema Day where

194162 toParamSchema _ = timeParamSchema "date"

195163

196−-- |

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

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

199−instance ToParamSchema TimeOfDay where

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

201−

202164-- |

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

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

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

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

219181

220182instance ToParamSchema NominalDiffTime where

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

183+ toParamSchema _ = toParamSchema (Proxy :: Proxy Integer)

222184

223185instance ToParamSchema T.Text where

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

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

226188instance ToParamSchema TL.Text where

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

228190

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−

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

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

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

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

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

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

258198

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

260−

261199instance ToParamSchema a => ToParamSchema [a] where

262200 toParamSchema _ = mempty

263− & type_ ?~ SwaggerArray

201+ & type_ .~ SwaggerArray

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

265203

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

@@ -280,25 +218,20 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where

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

281219instance ToParamSchema () where

282220 toParamSchema _ = mempty

283− & type_ ?~ SwaggerString

221+ & type_ .~ SwaggerString

284222 & enum_ ?~ ["_"]

285223

286−instance ToParamSchema UUID where

287− toParamSchema _ = mempty

288− & type_ ?~ SwaggerString

289− & format ?~ "uuid"

290−

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

292225--

293226-- >>> :set -XDeriveGeneric

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

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

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

297−genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t

230+genericToParamSchema :: forall proxy a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> proxy a -> ParamSchema t

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

299232

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

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

234+ gtoParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t

302235

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

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

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

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

317250

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

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

252+ genumParamSchema :: SchemaOptions -> proxy f -> ParamSchema t -> ParamSchema t

320253

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

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

323256

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

325258 genumParamSchema opts _ s = s

326− & type_ ?~ SwaggerString

259+ & type_ .~ SwaggerString

327260 & enum_ %~ addEnumValue tag

328261 where

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

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

333266

334267data Proxy3 a b c = Proxy3

335268

336−-- $setup

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

src/Data/Swagger/Internal/Schema.hs+95−238

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

32{-# LANGUAGE DefaultSignatures #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

@@ -14,13 +13,6 @@

1413{-# LANGUAGE TypeFamilies #-}

1514{-# LANGUAGE TypeOperators #-}

1615{-# LANGUAGE TypeSynonymInstances #-}

17−{-# LANGUAGE UndecidableInstances #-}

18−#if __GLASGOW_HASKELL__ >= 800

19−-- Few generics related redundant constraints

20−{-# OPTIONS_GHC -Wno-redundant-constraints #-}

21−-- For TypeErrors

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

23−#endif

2416#include "overlapping-compat.h"

2517module Data.Swagger.Internal.Schema where

2618

@@ -30,25 +22,27 @@ import Prelude.Compat

3022import Control.Lens

3123import Data.Data.Lens (template)

3224

25+import Control.Applicative

3326import Control.Monad

3427import Control.Monad.Writer

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

28+import Data.Aeson

29+import qualified Data.Aeson.Types as Aeson

3630import Data.Char

3731import Data.Data (Data)

3832import Data.Foldable (traverse_)

33+import Data.Function (on)

3934import Data.HashMap.Strict (HashMap)

4035import qualified Data.HashMap.Strict as HashMap

4136import "unordered-containers" Data.HashSet (HashSet)

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

38+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

4339import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

4440import Data.Int

4541import Data.IntSet (IntSet)

4642import Data.IntMap (IntMap)

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

4843import Data.Map (Map)

4944import Data.Proxy

5045import Data.Scientific (Scientific)

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

5246import Data.Set (Set)

5347import qualified Data.Text as T

5448import qualified Data.Text.Lazy as TL

@@ -57,11 +51,8 @@ import qualified Data.Vector as V

5751import qualified Data.Vector.Primitive as VP

5852import qualified Data.Vector.Storable as VS

5953import qualified Data.Vector.Unboxed as VU

60−import Data.Version (Version)

61−import Numeric.Natural.Compat (Natural)

6254import Data.Word

6355import GHC.Generics

64−import qualified Data.UUID.Types as UUID

6556

6657import Data.Swagger.Declare

6758import Data.Swagger.Internal

@@ -69,13 +60,9 @@ import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))

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

7061import qualified Data.Swagger.Lens as Swagger

7162import Data.Swagger.SchemaOptions

72−import Data.Swagger.Internal.TypeShape

7363

74−#if __GLASGOW_HASKELL__ < 800

75−#else

76−import qualified Data.ByteString as BS

77−import qualified Data.ByteString.Lazy as BSL

78−import GHC.TypeLits (TypeError, ErrorMessage(..))

64+#ifdef __DOCTEST__

65+import Data.Swagger.Lens (name, schema)

7966#endif

8067

8168unnamed :: Schema -> NamedSchema

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

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

10390--

10491-- import Control.Lens

105−-- import Data.Proxy

106−-- import Data.Swagger

10792--

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

10994--

11095-- instance ToSchema Coord where

111−-- declareNamedSchema _ = do

96+-- declareNamedSchema = do

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

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

114−-- & type_ ?~ SwaggerObject

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

99+-- & type_ .~ SwaggerObject

115100-- & properties .~

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

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

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

142127 -- together with all used definitions.

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

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

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

130+ declareNamedSchema :: proxy a -> Declare (Definitions Schema) NamedSchema

131+ default declareNamedSchema :: (Generic a, GToSchema (Rep a)) => proxy a -> Declare (Definitions Schema) NamedSchema

148132 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

149133

150−instance ToSchema TimeOfDay where

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

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

153−

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

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

135+declareSchema :: ToSchema a => proxy a -> Declare (Definitions Schema) Schema

156136declareSchema = fmap _namedSchemaSchema . declareNamedSchema

157137

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

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

166146-- Just "Day"

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

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

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

149+toNamedSchema :: ToSchema a => proxy a -> NamedSchema

170150toNamedSchema = undeclare . declareNamedSchema

171151

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

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

176156--

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

178158-- Just "UTCTime"

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

159+schemaName :: ToSchema a => proxy a -> Maybe T.Text

180160schemaName = _namedSchemaName . toNamedSchema

181161

182162-- | Convert a type into a schema.

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

186166--

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

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

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

169+toSchema :: ToSchema a => proxy a -> Schema

190170toSchema = _namedSchemaSchema . toNamedSchema

191171

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

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

197177--

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

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

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

180+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema

201181toSchemaRef = undeclare . declareSchemaRef

202182

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

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

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

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

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

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

190+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)

211191declareSchemaRef proxy = do

212192 case toNamedSchema proxy of

213193 NamedSchema (Just name) schema -> do

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

269249--

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

271251-- when inlining recursive schemas.

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

252+toInlinedSchema :: ToSchema a => proxy a -> Schema

273253toInlinedSchema proxy = inlineAllSchemas defs schema

274254 where

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

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

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

299279binarySchema :: Schema

300280binarySchema = mempty

301− & type_ ?~ SwaggerString

281+ & type_ .~ SwaggerString

302282 & format ?~ "binary"

303283

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

305285byteSchema :: Schema

306286byteSchema = mempty

307− & type_ ?~ SwaggerString

287+ & type_ .~ SwaggerString

308288 & format ?~ "byte"

309289

310290-- | Default schema for password string.

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

312292passwordSchema :: Schema

313293passwordSchema = mempty

314− & type_ ?~ SwaggerString

294+ & type_ .~ SwaggerString

315295 & format ?~ "password"

316296

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

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

337317 sketch js@(Bool _) = go js

338318 sketch js = go js & example ?~ js

339319

340− go Null = mempty & type_ ?~ SwaggerNull

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

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

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

344− go (Array xs) = mempty

345− & type_ ?~ SwaggerArray

320+ go Null = mempty & type_ .~ SwaggerNull

321+ go js@(Bool _) = mempty & type_ .~ SwaggerBoolean

322+ go js@(String s) = mempty & type_ .~ SwaggerString

323+ go js@(Number n) = mempty & type_ .~ SwaggerNumber

324+ go js@(Array xs) = mempty

325+ & type_ .~ SwaggerArray

346326 & items ?~ case ischema of

347327 Just s -> SwaggerItemsObject (Inline s)

348328 _ -> SwaggerItemsArray (map Inline ys)

@@ -351,10 +331,10 @@ sketchSchema = sketch . toJSON

351331 allSame = and ((zipWith (==)) ys (tail ys))

352332

353333 ischema = case ys of

354− (z:_) | allSame -> Just z

355− _ -> Nothing

356− go (Object o) = mempty

357− & type_ ?~ SwaggerObject

334+ (z:zs) | allSame -> Just z

335+ _ -> Nothing

336+ go js@(Object o) = mempty

337+ & type_ .~ SwaggerObject

358338 & required .~ HashMap.keys o

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

360340

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

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

378358sketchStrictSchema = go . toJSON

379359 where

380− go Null = mempty & type_ ?~ SwaggerNull

360+ go Null = mempty & type_ .~ SwaggerNull

381361 go js@(Bool _) = mempty

382− & type_ ?~ SwaggerBoolean

362+ & type_ .~ SwaggerBoolean

383363 & enum_ ?~ [js]

384364 go js@(String s) = mempty

385− & type_ ?~ SwaggerString

365+ & type_ .~ SwaggerString

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

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

388368 & pattern ?~ s

389369 & enum_ ?~ [js]

390370 go js@(Number n) = mempty

391− & type_ ?~ SwaggerNumber

371+ & type_ .~ SwaggerNumber

392372 & maximum_ ?~ n

393373 & minimum_ ?~ n

394374 & multipleOf ?~ n

395375 & enum_ ?~ [js]

396376 go js@(Array xs) = mempty

397− & type_ ?~ SwaggerArray

377+ & type_ .~ SwaggerArray

398378 & maxItems ?~ fromIntegral sz

399379 & minItems ?~ fromIntegral sz

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

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

404384 sz = length xs

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

406386 go js@(Object o) = mempty

407− & type_ ?~ SwaggerObject

387+ & type_ .~ SwaggerObject

408388 & required .~ names

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

410390 & maxProperties ?~ fromIntegral (length names)

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

414394 names = HashMap.keys o

415395

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

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

397+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

418398

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

420400 declareNamedSchema _ = do

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

422402 return $ unnamed $ mempty

423− & type_ ?~ SwaggerArray

403+ & type_ .~ SwaggerArray

424404 & items ?~ SwaggerItemsObject ref

425405

426406instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

427407instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema

428408instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema

429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema

430409instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema

431410instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema

432411instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema

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

446425instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema

447426instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema

448427

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

450−

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

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

453430

@@ -456,11 +433,6 @@ instance (ToSchema a, ToSchema b) => ToSchema (Either a b)

456433instance ToSchema () where

457434 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)

458435

459−-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.

460−instance ToSchema UUID.UUID where

461− declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p

462− & example ?~ toJSON (UUID.toText UUID.nil)

463−

464436instance (ToSchema a, ToSchema b) => ToSchema (a, b)

465437instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)

466438instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)

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

470442

471443timeSchema :: T.Text -> Schema

472444timeSchema fmt = mempty

473− & type_ ?~ SwaggerString

445+ & type_ .~ SwaggerString

474446 & format ?~ fmt

475447

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

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

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

492464

493465instance ToSchema NominalDiffTime where

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

466+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)

495467

496468-- |

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

@@ -503,20 +475,6 @@ instance ToSchema UTCTime where

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

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

505477

506−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema

507−

508−#if __GLASGOW_HASKELL__ < 800

509−#else

510−type family ToSchemaByteStringError bs where

511− ToSchemaByteStringError bs = TypeError

512− ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."

513− :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."

514− :$$: Text "Consider using byteSchema or binarySchema templates." )

515−

516−instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible"

517−instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"

518−#endif

519−

520478instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))

521479

522480-- | NOTE: This schema does not account for the uniqueness of keys.

@@ -524,27 +482,12 @@ instance ToSchema a => ToSchema (IntMap a) where

524482 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])

525483

526484#if MIN_VERSION_aeson(1,0,0)

527−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where

528− declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of

529− ToJSONKeyText _ _ -> declareObjectMapSchema

530− ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])

531− where

532− declareObjectMapSchema = do

533− schema <- declareSchemaRef (Proxy :: Proxy v)

534− return $ unnamed $ mempty

535− & type_ ?~ SwaggerObject

536− & additionalProperties ?~ AdditionalPropertiesSchema schema

537−

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

539− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))

540−

541−#else

542485

543486instance ToSchema a => ToSchema (Map String a) where

544487 declareNamedSchema _ = do

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

546489 return $ unnamed $ mempty

547− & type_ ?~ SwaggerObject

490+ & type_ .~ SwaggerObject

548491 & additionalProperties ?~ schema

549492

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

@@ -554,13 +497,23 @@ instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ =

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

555498instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

556499

557−#endif

500+#else

558501

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

502+instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where

503+ declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction v of

504+ ToJSONKeyText _ _ -> declareObjectMapSchema

505+ ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])

506+ where

507+ declareObjectMapSchema = do

508+ schema <- declareSchemaRef (Proxy :: Proxy v)

509+ return $ unnamed $ mempty

510+ & type_ .~ SwaggerObject

511+ & additionalProperties ?~ schema

512+

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

514+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))

515+

516+#endif

564517

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

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

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

575528

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

577530

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−

585531instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema

586532instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

587533

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

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

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

593539

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

595−

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

597541--

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

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

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

544+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema

601545toSchemaBoundedIntegral _ = mempty

602− & type_ ?~ SwaggerInteger

546+ & type_ .~ SwaggerInteger

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

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

605549

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

607−genericToNamedSchemaBoundedIntegral :: forall a d f.

551+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

608552 ( Bounded a, Integral a

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

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

554+ => SchemaOptions -> proxy a -> NamedSchema

611555genericToNamedSchemaBoundedIntegral opts 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

556+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)

668557

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

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

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

672−genericDeclareSchema = genericDeclareSchemaUnrestricted

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

560+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy

673561

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

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

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

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

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

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

680−genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

681−

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

683−--

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

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

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

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

688−

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

690−--

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

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

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

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

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

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

567+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

702568

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

704−gdatatypeSchemaName opts _ = case orig of

569+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

570+gdatatypeSchemaName opts _ = case name of

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

706572 _ -> Nothing

707573 where

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

709− name = datatypeNameModifier opts orig

574+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))

710575

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

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

713− SchemaOptions -> Proxy a -> NamedSchema

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

577+paramSchemaToNamedSchema :: forall a d f proxy.

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

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

580+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)

715581

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

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

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

583+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema

584+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)

719585

720586nullarySchema :: Schema

721587nullarySchema = mempty

722− & type_ ?~ SwaggerArray

588+ & type_ .~ SwaggerArray

723589 & items ?~ SwaggerItemsArray []

724590

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

591+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema

726592gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

727593

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

594+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema

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

730596

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

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

745611 gdeclareNamedSchema = gdeclareNamedSumSchema

746612

747613-- | Single field constructor.

748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where

614+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where

749615 gdeclareNamedSchema opts _ s

750616 | unwrapUnaryRecords opts = fieldSchema

751617 | otherwise =

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

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

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

761627

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

628+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)

763629gdeclareSchemaRef opts proxy = do

764630 case gtoNamedSchema opts proxy of

765631 NamedSchema (Just name) schema -> do

@@ -778,7 +644,7 @@ gdeclareSchemaRef opts proxy = do

778644 return $ Ref (Reference name)

779645 _ -> Inline <$> gdeclareSchema opts proxy

780646

781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)

647+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)

782648appendItem x Nothing = Just (SwaggerItemsArray [x])

783649appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))

784650appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

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

790656 return $

791657 if T.null fname

792658 then schema

793− & type_ ?~ SwaggerArray

659+ & type_ .~ SwaggerArray

794660 & items %~ appendItem ref

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

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

797661 else schema

798− & type_ ?~ SwaggerObject

662+ & type_ .~ SwaggerObject

799663 & properties . at fname ?~ ref

800664 & if isRequiredField

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

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

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

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

819683

820−instance ( GSumToSchema f

821− , GSumToSchema g

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

823− where

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

824685 gdeclareNamedSchema = gdeclareNamedSumSchema

825686

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

687+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

827688gdeclareNamedSumSchema opts proxy s

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

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

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

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

833694

834695 toStringTag schema = mempty

835− & type_ ?~ SwaggerString

696+ & type_ .~ SwaggerString

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

837698

838699type AllNullary = All

839700

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

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

701+class GSumToSchema f where

702+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

842703

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

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

845706

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

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

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

708+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema

848709gsumConToSchemaWith ref opts _ schema = schema

849− & type_ ?~ SwaggerObject

710+ & type_ .~ SwaggerObject

850711 & properties . at tag ?~ ref

851712 & maxProperties ?~ 1

852713 & minProperties ?~ 1

853714 where

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

855716

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

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

717+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>

718+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema

858719gsumConToSchema opts proxy schema = do

859720 ref <- gdeclareSchemaRef opts proxy

860721 return $ gsumConToSchemaWith ref opts proxy schema

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

876737

877738data Proxy3 a b c = Proxy3

878739

879−-- $setup

880−-- >>> import Data.Swagger

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

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

src/Data/Swagger/Internal/Schema/Validation.hs+78−263

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

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE GADTs #-}

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE GADTs #-}

75{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE LambdaCase #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PackageImports #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TemplateHaskell #-}

14−{-# LANGUAGE UndecidableInstances #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE PackageImports #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TemplateHaskell #-}

12+{-# LANGUAGE UndecidableInstances #-}

1513-- |

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

@@ -22,34 +20,30 @@

2220-- Validate JSON values with Swagger Schema.

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

2422

25−import Prelude ()

26−import Prelude.Compat

23+import Control.Applicative

24+import Control.Lens

25+import Control.Lens.TH

26+import Control.Monad (when)

2727

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

28+import Data.Aeson hiding (Result)

29+import Data.Foldable (traverse_, for_, sequenceA_)

30+import Data.HashMap.Strict (HashMap)

31+import qualified Data.HashMap.Strict as HashMap

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

40−import Data.Proxy

41−import Data.Scientific (Scientific, isInteger)

42−import Data.Text (Text)

43−import qualified Data.Text as Text

44−import qualified Data.Text.Lazy as TL

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

46−import Data.Vector (Vector)

47−import qualified Data.Vector as Vector

48−

49−import Data.Swagger.Declare

50−import Data.Swagger.Internal

51−import Data.Swagger.Internal.Schema

52−import Data.Swagger.Lens

33+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

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

35+import Data.Monoid

36+import Data.Proxy

37+import Data.Scientific (Scientific, isInteger)

38+import Data.Text (Text)

39+import qualified Data.Text as Text

40+import Data.Vector (Vector)

41+import qualified Data.Vector as Vector

42+

43+import Data.Swagger.Declare

44+import Data.Swagger.Internal

45+import Data.Swagger.Internal.Schema

46+import Data.Swagger.Lens

5347

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

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

@@ -58,119 +52,21 @@ import Data.Swagger.Lens

5852--

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

6054-- 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.

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

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

6957

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

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

7260--

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 =

170− case runValidation (validateWithSchema js) cfg sch of

61+-- For validation without patterns see @'validateToJSON'@.

62+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>

63+ (Pattern -> Text -> Bool) -> a -> [ValidationError]

64+validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of

17165 Failed xs -> xs

17266 Passed _ -> mempty

17367 where

68+ (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

69+ js = toJSON x

17470 cfg = defaultConfig

17571 { configPatternChecker = checker

17672 , configDefinitions = defs }

@@ -199,7 +95,7 @@ instance Alternative Result where

19995instance Monad Result where

20096 return = pure

20197 Passed x >>= f = f x

202− Failed xs >>= _ = Failed xs

98+ Failed xs >>= f = Failed xs

20399

204100-- | Validation configuration.

205101data Config = Config

@@ -244,7 +140,7 @@ instance Choice Validation where

244140

245141instance Monad (Validation s) where

246142 return = pure

247− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)

143+ Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)

248144 (>>) = (*>)

249145

250146withConfig :: (Config -> Validation s a) -> Validation s a

@@ -263,17 +159,11 @@ valid = pure ()

263159

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

265161-- and property checker.

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

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

268− case sch ^. l of

269− Nothing -> missing

270− Just x -> g x

271−

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

273−-- and property checker.

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

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

276−check = checkMissing valid

163+check l g = withSchema $ \schema ->

164+ case schema ^. l of

165+ Nothing -> valid

166+ Just x -> g x

277167

278168-- | Validate same value with different schema.

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

@@ -291,7 +181,7 @@ withRef (Reference ref) f = withConfig $ \cfg ->

291181 Just s -> f s

292182

293183validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

294−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)

184+validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)

295185validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

296186

297187-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

@@ -313,9 +203,9 @@ validateInteger n = do

313203 validateNumber n

314204

315205validateNumber :: Scientific -> Validation (ParamSchema t) ()

316−validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do

317− let exMax = Just True == sch ^. exclusiveMaximum

318− exMin = Just True == sch ^. exclusiveMinimum

206+validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do

207+ let exMax = Just True == schema ^. exclusiveMaximum

208+ exMin = Just True == schema ^. exclusiveMinimum

319209

320210 check maximum_ $ \m ->

321211 when (if exMax then (n >= m) else (n > m)) $

@@ -372,8 +262,8 @@ validateArray xs = do

372262 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

373263

374264validateObject :: HashMap Text Value -> Validation Schema ()

375−validateObject o = withSchema $ \sch ->

376− case sch ^. discriminator of

265+validateObject o = withSchema $ \schema ->

266+ case schema ^. discriminator of

377267 Just pname -> case fromJSON <$> HashMap.lookup pname o of

378268 Just (Success ref) -> validateWithSchemaRef ref (Object o)

379269 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

@@ -392,120 +282,45 @@ validateObject o = withSchema $ \sch ->

392282 where

393283 size = fromIntegral (HashMap.size o)

394284

395− validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)

396− validateReq n =

397− when (not (HashMap.member n o)) $

398− invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))

285+ validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)

286+ validateReq name =

287+ when (not (HashMap.member name o)) $

288+ invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))

399289

400− validateProps = withSchema $ \sch -> do

290+ validateProps = withSchema $ \schema -> do

401291 for_ (HashMap.toList o) $ \(k, v) ->

402292 case v of

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

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

404294 _ ->

405− case InsOrdHashMap.lookup k (sch ^. properties) of

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

295+ case InsOrdHashMap.lookup k (schema ^. properties) of

296+ Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

407297 Just s -> validateWithSchemaRef s v

408298

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−

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

418300validateEnum value = do

419301 check enum_ $ \xs ->

420302 when (value `notElem` xs) $

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

422304

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−

470305validateSchemaType :: Value -> Validation Schema ()

471−validateSchemaType value = withSchema $ \sch ->

472− case (sch ^. type_, value) of

473− (Just SwaggerNull, Null) -> valid

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

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

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

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

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

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

480− (Nothing, Null) -> valid

481− (Nothing, Bool _) -> valid

482− -- Number by default

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

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

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

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

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

306+validateSchemaType value = withSchema $ \schema ->

307+ case (schema ^. type_, value) of

308+ (SwaggerNull, Null) -> valid

309+ (SwaggerBoolean, Bool _) -> valid

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

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

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

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

314+ (SwaggerObject, Object o) -> validateObject o

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

488316

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

490−validateParamSchemaType value = withSchema $ \sch ->

491− case (sch ^. type_, value) of

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

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

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

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

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

497− (Nothing, Bool _) -> valid

498− -- Number by default

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

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

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

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

503−

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

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

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

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

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

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

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

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

318+validateParamSchemaType value = withSchema $ \schema ->

319+ case (schema ^. type_, value) of

320+ (SwaggerBoolean, Bool _) -> valid

321+ (SwaggerInteger, Number n) -> validateInteger n

322+ (SwaggerNumber, Number n) -> validateNumber n

323+ (SwaggerString, String s) -> validateString s

324+ (SwaggerArray, Array xs) -> validateArray xs

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

326+

src/Data/Swagger/Internal/TypeShape.hsdeleted−66

@@ -1,66 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE TypeOperators #-}

7−{-# LANGUAGE UndecidableInstances #-}

8−

9−module Data.Swagger.Internal.TypeShape where

10−

11−import Data.Proxy

12−import GHC.Generics

13−import GHC.TypeLits

14−import GHC.Exts (Constraint)

15−

16−-- | Shape of a datatype.

17−data TypeShape

18− = Enumeration -- ^ A simple enumeration.

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

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

21−

22−-- | A combined shape for a product type.

23−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

24− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products

25− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products

26− ProdCombine a b = SumOfProducts

27−

28−-- | A combined shape for a sum type.

29−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

30− SumCombine Enumeration Enumeration = Enumeration

31− SumCombine SumOfProducts SumOfProducts = SumOfProducts

32− SumCombine a b = Mixed

33−

34−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where

35− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))

36−

37−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where

38− GenericHasSimpleShape t f Enumeration = ()

39− GenericHasSimpleShape t f SumOfProducts = ()

40−#if __GLASGOW_HASKELL__ < 800

41− GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t

42−

43−class CannotDeriveSchemaForMixedSumType t where

44−#else

45− GenericHasSimpleShape t f Mixed =

46− TypeError

47− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t

48− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."

49− :$$: Text "Swagger does not have a good representation for these types."

50− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"

51− :$$: Text "that matches aeson's Generic-based toJSON,"

52− :$$: Text "but that's not supported by some Swagger tools."

53− )

54−#endif

55−

56−-- | Infer a 'TypeShape' for a generic representation of a type.

57−type family GenericShape (g :: * -> *) :: TypeShape

58−

59−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)

60−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)

61−type instance GenericShape (D1 d f) = GenericShape f

62−type instance GenericShape (C1 c U1) = Enumeration

63−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts

64−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts

65−

66−

src/Data/Swagger/Internal/Utils.hs+1

@@ -21,6 +21,7 @@ import qualified Data.HashMap.Strict as HashMap

2121import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

2222import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

2323import Data.Map (Map)

24+import Data.Monoid

2425import Data.Set (Set)

2526import Data.Text (Text)

2627import GHC.Generics

src/Data/Swagger/Lens.hs+6−16

@@ -62,21 +62,17 @@ makePrisms ''Referenced

6262

6363_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]

6464_SwaggerItemsArray

65− = unto (\x -> SwaggerItemsArray x)

66−{- \x -> case x of

65+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of

6766 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

6867 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

6968 SwaggerItemsArray a -> Right a

70−-}

7169

7270_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

7371_SwaggerItemsObject

74− = unto (\x -> SwaggerItemsObject x)

75−{- \x -> case x of

72+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of

7673 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

7774 SwaggerItemsObject o -> Right o

7875 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

79−-}

8076

8177_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

8278_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

@@ -96,19 +92,13 @@ instance At Responses where at n = responses . at n

9692instance Ixed Operation where ix n = responses . ix n

9793instance At Operation where at n = responses . at n

9894

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−

10595instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

10696

10797-- HasType instances

108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_

109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_

98+instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_

99+instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

100+instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

101+instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_

112102

113103-- HasDefault instances

114104instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

src/Data/Swagger/Operation.hs+12−10

@@ -30,23 +30,24 @@ module Data.Swagger.Operation (

3030 declareResponse,

3131) where

3232

33−import Prelude ()

34−import Prelude.Compat

35−

33+import Control.Applicative

34+import Control.Arrow

3635import Control.Lens

3736import Data.Data.Lens

38−import Data.List.Compat

37+import qualified Data.HashMap.Strict as HashMap

38+import Data.List

3939import Data.Maybe (mapMaybe)

40−import Data.Proxy

40+import Data.Monoid

4141import qualified Data.Set as Set

42+import Data.Traversable

4243

4344import Data.Swagger.Declare

4445import Data.Swagger.Internal

4546import Data.Swagger.Lens

4647import Data.Swagger.Schema

4748

49+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

4850import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

49−import qualified Data.HashSet.InsOrd as InsOrdHS

5051

5152-- $setup

5253-- >>> import Data.Aeson

@@ -112,15 +113,15 @@ applyTags = applyTagsFor allOperations

112113-- list of tags.

113114applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

114115applyTagsFor ops ts swag = swag

115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))

116− & tags %~ (<> InsOrdHS.fromList ts)

116+ & ops . tags %~ (<> Set.fromList (map _tagName ts))

117+ & tags %~ (<> Set.fromList ts)

117118

118119-- | Construct a response with @'Schema'@ while declaring all

119120-- necessary schema definitions.

120121--

121122-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

122123-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

123−declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response

124+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

124125declareResponse proxy = do

125126 s <- declareSchemaRef proxy

126127 return (mempty & schema ?~ s)

@@ -186,8 +187,9 @@ setResponseForWith ops f code dres swag = swag

186187 where

187188 (defs, new) = runDeclare dres mempty

188189

189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of

190+ combine (Just (Ref (Reference name))) = case swag ^. responses.at name of

190191 Just old -> f old new

191192 Nothing -> new -- response name can't be dereferenced, replacing with new response

192193 combine (Just (Inline old)) = f old new

193194 combine Nothing = new

195+

src/Data/Swagger/Optics.hsdeleted−597

@@ -1,597 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE OverloadedLabels #-}

5−{-# LANGUAGE TemplateHaskell #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE UndecidableInstances #-}

8−{-# OPTIONS_GHC -fno-warn-orphans #-}

9−-- |

10−-- Module: Data.Swagger.Optics

11−-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>

12−-- Stability: experimental

13−--

14−-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>

15−-- library.

16−--

17−-- >>> import Data.Aeson

18−-- >>> import Optics.Core

19−-- >>> :set -XOverloadedLabels

20−--

21−-- Example from the "Data.Swagger" module using @optics@:

22−--

23−-- >>> :{

24−-- encode $ (mempty :: Swagger)

25−-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]

26−-- & #paths .~

27−-- [ ("/user", mempty & #get ?~ (mempty

28−-- & #produces ?~ MimeList ["application/json"]

29−-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))

30−-- & at 404 ?~ "User info not found")) ]

31−-- :}

32−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"

33−--

34−-- For convenience optics are defined as /labels/. It means that field accessor

35−-- names can be overloaded for different types. One such common field is

36−-- @#description@. Many components of a Swagger specification can have

37−-- descriptions, and you can use the same name for them:

38−--

39−-- >>> encode $ (mempty :: Response) & #description .~ "No content"

40−-- "{\"description\":\"No content\"}"

41−-- >>> :{

42−-- encode $ (mempty :: Schema)

43−-- & #type ?~ SwaggerBoolean

44−-- & #description ?~ "To be or not to be"

45−-- :}

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

47−--

48−-- @'ParamSchema'@ is basically the /base schema specification/ and many types

49−-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively

50−-- made fields of the type that has it. For example, you can use @#type@ to

51−-- access @'SwaggerType'@ of @'Header'@ schema without having to use

52−-- @#paramSchema@:

53−--

54−-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber

55−-- "{\"type\":\"number\"}"

56−--

57−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and

58−-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:

59−--

60−-- >>> :{

61−-- encode $ (mempty :: Operation)

62−-- & at 404 ?~ "Not found"

63−-- :}

64−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"

65−--

66−module Data.Swagger.Optics () where

67−

68−import Data.Aeson (Value)

69−import Data.Scientific (Scientific)

70−import Data.Swagger.Internal

71−import Data.Text (Text)

72−import Optics.Core

73−import Optics.TH

74−

75−-- Lenses

76−

77−makeFieldLabels ''Swagger

78−makeFieldLabels ''Host

79−makeFieldLabels ''Info

80−makeFieldLabels ''Contact

81−makeFieldLabels ''License

82−makeFieldLabels ''PathItem

83−makeFieldLabels ''Tag

84−makeFieldLabels ''Operation

85−makeFieldLabels ''Param

86−makeFieldLabels ''ParamOtherSchema

87−makeFieldLabels ''Header

88−makeFieldLabels ''Schema

89−makeFieldLabels ''NamedSchema

90−makeFieldLabels ''ParamSchema

91−makeFieldLabels ''Xml

92−makeFieldLabels ''Responses

93−makeFieldLabels ''Response

94−makeFieldLabels ''SecurityScheme

95−makeFieldLabels ''ApiKeyParams

96−makeFieldLabels ''OAuth2Params

97−makeFieldLabels ''ExternalDocs

98−

99−-- Prisms

100−

101−makePrismLabels ''ParamAnySchema

102−makePrismLabels ''SecuritySchemeType

103−makePrismLabels ''Referenced

104−

105−-- SwaggerItems prisms

106−

107−instance

108− ( a ~ [Referenced Schema]

109− , b ~ [Referenced Schema]

110− ) => LabelOptic "_SwaggerItemsArray"

111− A_Review

112− (SwaggerItems 'SwaggerKindSchema)

113− (SwaggerItems 'SwaggerKindSchema)

114− a

115− b where

116− labelOptic = unto (\x -> SwaggerItemsArray x)

117− {-# INLINE labelOptic #-}

118−

119−instance

120− ( a ~ Referenced Schema

121− , b ~ Referenced Schema

122− ) => LabelOptic "_SwaggerItemsObject"

123− A_Review

124− (SwaggerItems 'SwaggerKindSchema)

125− (SwaggerItems 'SwaggerKindSchema)

126− a

127− b where

128− labelOptic = unto (\x -> SwaggerItemsObject x)

129− {-# INLINE labelOptic #-}

130−

131−instance

132− ( a ~ (Maybe (CollectionFormat t), ParamSchema t)

133− , b ~ (Maybe (CollectionFormat t), ParamSchema t)

134− ) => LabelOptic "_SwaggerItemsPrimitive"

135− A_Review

136− (SwaggerItems t)

137− (SwaggerItems t)

138− a

139− b where

140− labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)

141− {-# INLINE labelOptic #-}

142−

143−-- =============================================================

144−-- More helpful instances for easier access to schema properties

145−

146−type instance Index Responses = HttpStatusCode

147−type instance Index Operation = HttpStatusCode

148−

149−type instance IxValue Responses = Referenced Response

150−type instance IxValue Operation = Referenced Response

151−

152−instance Ixed Responses where

153− ix n = #responses % ix n

154− {-# INLINE ix #-}

155−instance At Responses where

156− at n = #responses % at n

157− {-# INLINE at #-}

158−

159−instance Ixed Operation where

160− ix n = #responses % ix n

161− {-# INLINE ix #-}

162−instance At Operation where

163− at n = #responses % at n

164− {-# INLINE at #-}

165−

166−-- #paramSchema

167−

168−instance

169− ( a ~ ParamSchema 'SwaggerKindSchema

170− , b ~ ParamSchema 'SwaggerKindSchema

171− ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where

172− labelOptic = #schema % #paramSchema

173− {-# INLINE labelOptic #-}

174−

175−-- #type

176−

177−instance

178− ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

179− , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

180− ) => LabelOptic "type" A_Lens Header Header a b where

181− labelOptic = #paramSchema % #type

182− {-# INLINE labelOptic #-}

183−

184−instance

185− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

186− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

187− ) => LabelOptic "type" A_Lens Schema Schema a b where

188− labelOptic = #paramSchema % #type

189− {-# INLINE labelOptic #-}

190−

191−instance

192− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

193− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

194− ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where

195− labelOptic = #paramSchema % #type

196− {-# INLINE labelOptic #-}

197−

198−instance

199− ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

200− , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

201− ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where

202− labelOptic = #paramSchema % #type

203− {-# INLINE labelOptic #-}

204−

205−-- #default

206−

207−instance

208− ( a ~ Maybe Value, b ~ Maybe Value

209− ) => LabelOptic "default" A_Lens Header Header a b where

210− labelOptic = #paramSchema % #default

211− {-# INLINE labelOptic #-}

212−

213−instance

214− ( a ~ Maybe Value, b ~ Maybe Value

215− ) => LabelOptic "default" A_Lens Schema Schema a b where

216− labelOptic = #paramSchema % #default

217− {-# INLINE labelOptic #-}

218−

219−instance

220− ( a ~ Maybe Value, b ~ Maybe Value

221− ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where

222− labelOptic = #paramSchema % #default

223− {-# INLINE labelOptic #-}

224−

225−instance

226− ( a ~ Maybe Value, b ~ Maybe Value

227− ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where

228− labelOptic = #paramSchema % #default

229− {-# INLINE labelOptic #-}

230−

231−-- #format

232−

233−instance

234− ( a ~ Maybe Format, b ~ Maybe Format

235− ) => LabelOptic "format" A_Lens Header Header a b where

236− labelOptic = #paramSchema % #format

237− {-# INLINE labelOptic #-}

238−

239−instance

240− ( a ~ Maybe Format, b ~ Maybe Format

241− ) => LabelOptic "format" A_Lens Schema Schema a b where

242− labelOptic = #paramSchema % #format

243− {-# INLINE labelOptic #-}

244−

245−instance

246− ( a ~ Maybe Format, b ~ Maybe Format

247− ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where

248− labelOptic = #paramSchema % #format

249− {-# INLINE labelOptic #-}

250−

251−instance

252− ( a ~ Maybe Format, b ~ Maybe Format

253− ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where

254− labelOptic = #paramSchema % #format

255− {-# INLINE labelOptic #-}

256−

257−-- #items

258−

259−instance

260− ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

261− , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

262− ) => LabelOptic "items" A_Lens Header Header a b where

263− labelOptic = #paramSchema % #items

264− {-# INLINE labelOptic #-}

265−

266−instance

267− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

268− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

269− ) => LabelOptic "items" A_Lens Schema Schema a b where

270− labelOptic = #paramSchema % #items

271− {-# INLINE labelOptic #-}

272−

273−instance

274− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

275− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

276− ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where

277− labelOptic = #paramSchema % #items

278− {-# INLINE labelOptic #-}

279−

280−instance

281− ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

282− , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

283− ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where

284− labelOptic = #paramSchema % #items

285− {-# INLINE labelOptic #-}

286−

287−-- #maximum

288−

289−instance

290− ( a ~ Maybe Scientific, b ~ Maybe Scientific

291− ) => LabelOptic "maximum" A_Lens Header Header a b where

292− labelOptic = #paramSchema % #maximum

293− {-# INLINE labelOptic #-}

294−

295−instance

296− ( a ~ Maybe Scientific, b ~ Maybe Scientific

297− ) => LabelOptic "maximum" A_Lens Schema Schema a b where

298− labelOptic = #paramSchema % #maximum

299− {-# INLINE labelOptic #-}

300−

301−instance

302− ( a ~ Maybe Scientific, b ~ Maybe Scientific

303− ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where

304− labelOptic = #paramSchema % #maximum

305− {-# INLINE labelOptic #-}

306−

307−instance

308− ( a ~ Maybe Scientific, b ~ Maybe Scientific

309− ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

310− labelOptic = #paramSchema % #maximum

311− {-# INLINE labelOptic #-}

312−

313−-- #exclusiveMaximum

314−

315−instance

316− ( a ~ Maybe Bool, b ~ Maybe Bool

317− ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where

318− labelOptic = #paramSchema % #exclusiveMaximum

319− {-# INLINE labelOptic #-}

320−

321−instance

322− ( a ~ Maybe Bool, b ~ Maybe Bool

323− ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where

324− labelOptic = #paramSchema % #exclusiveMaximum

325− {-# INLINE labelOptic #-}

326−

327−instance

328− ( a ~ Maybe Bool, b ~ Maybe Bool

329− ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where

330− labelOptic = #paramSchema % #exclusiveMaximum

331− {-# INLINE labelOptic #-}

332−

333−instance

334− ( a ~ Maybe Bool, b ~ Maybe Bool

335− ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

336− labelOptic = #paramSchema % #exclusiveMaximum

337− {-# INLINE labelOptic #-}

338−

339−-- #minimum

340−

341−instance

342− ( a ~ Maybe Scientific, b ~ Maybe Scientific

343− ) => LabelOptic "minimum" A_Lens Header Header a b where

344− labelOptic = #paramSchema % #minimum

345− {-# INLINE labelOptic #-}

346−

347−instance

348− ( a ~ Maybe Scientific, b ~ Maybe Scientific

349− ) => LabelOptic "minimum" A_Lens Schema Schema a b where

350− labelOptic = #paramSchema % #minimum

351− {-# INLINE labelOptic #-}

352−

353−instance

354− ( a ~ Maybe Scientific, b ~ Maybe Scientific

355− ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where

356− labelOptic = #paramSchema % #minimum

357− {-# INLINE labelOptic #-}

358−

359−instance

360− ( a ~ Maybe Scientific, b ~ Maybe Scientific

361− ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

362− labelOptic = #paramSchema % #minimum

363− {-# INLINE labelOptic #-}

364−

365−-- #exclusiveMinimum

366−

367−instance

368− ( a ~ Maybe Bool, b ~ Maybe Bool

369− ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where

370− labelOptic = #paramSchema % #exclusiveMinimum

371− {-# INLINE labelOptic #-}

372−

373−instance

374− ( a ~ Maybe Bool, b ~ Maybe Bool

375− ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where

376− labelOptic = #paramSchema % #exclusiveMinimum

377− {-# INLINE labelOptic #-}

378−

379−instance

380− ( a ~ Maybe Bool, b ~ Maybe Bool

381− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where

382− labelOptic = #paramSchema % #exclusiveMinimum

383− {-# INLINE labelOptic #-}

384−

385−instance

386− ( a ~ Maybe Bool, b ~ Maybe Bool

387− ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

388− labelOptic = #paramSchema % #exclusiveMinimum

389− {-# INLINE labelOptic #-}

390−

391−-- #maxLength

392−

393−instance

394− ( a ~ Maybe Integer, b ~ Maybe Integer

395− ) => LabelOptic "maxLength" A_Lens Header Header a b where

396− labelOptic = #paramSchema % #maxLength

397− {-# INLINE labelOptic #-}

398−

399−instance

400− ( a ~ Maybe Integer, b ~ Maybe Integer

401− ) => LabelOptic "maxLength" A_Lens Schema Schema a b where

402− labelOptic = #paramSchema % #maxLength

403− {-# INLINE labelOptic #-}

404−

405−instance

406− ( a ~ Maybe Integer, b ~ Maybe Integer

407− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where

408− labelOptic = #paramSchema % #maxLength

409− {-# INLINE labelOptic #-}

410−

411−instance

412− ( a ~ Maybe Integer, b ~ Maybe Integer

413− ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

414− labelOptic = #paramSchema % #maxLength

415− {-# INLINE labelOptic #-}

416−

417−-- #minLength

418−

419−instance

420− ( a ~ Maybe Integer, b ~ Maybe Integer

421− ) => LabelOptic "minLength" A_Lens Header Header a b where

422− labelOptic = #paramSchema % #minLength

423− {-# INLINE labelOptic #-}

424−

425−instance

426− ( a ~ Maybe Integer, b ~ Maybe Integer

427− ) => LabelOptic "minLength" A_Lens Schema Schema a b where

428− labelOptic = #paramSchema % #minLength

429− {-# INLINE labelOptic #-}

430−

431−instance

432− ( a ~ Maybe Integer, b ~ Maybe Integer

433− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where

434− labelOptic = #paramSchema % #minLength

435− {-# INLINE labelOptic #-}

436−

437−instance

438− ( a ~ Maybe Integer, b ~ Maybe Integer

439− ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

440− labelOptic = #paramSchema % #minLength

441− {-# INLINE labelOptic #-}

442−

443−-- #pattern

444−

445−instance

446− ( a ~ Maybe Text, b ~ Maybe Text

447− ) => LabelOptic "pattern" A_Lens Header Header a b where

448− labelOptic = #paramSchema % #pattern

449− {-# INLINE labelOptic #-}

450−

451−instance

452− ( a ~ Maybe Text, b ~ Maybe Text

453− ) => LabelOptic "pattern" A_Lens Schema Schema a b where

454− labelOptic = #paramSchema % #pattern

455− {-# INLINE labelOptic #-}

456−

457−instance

458− ( a ~ Maybe Text, b ~ Maybe Text

459− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where

460− labelOptic = #paramSchema % #pattern

461− {-# INLINE labelOptic #-}

462−

463−instance

464− ( a ~ Maybe Text, b ~ Maybe Text

465− ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where

466− labelOptic = #paramSchema % #pattern

467− {-# INLINE labelOptic #-}

468−

469−-- #maxItems

470−

471−instance

472− ( a ~ Maybe Integer, b ~ Maybe Integer

473− ) => LabelOptic "maxItems" A_Lens Header Header a b where

474− labelOptic = #paramSchema % #maxItems

475− {-# INLINE labelOptic #-}

476−

477−instance

478− ( a ~ Maybe Integer, b ~ Maybe Integer

479− ) => LabelOptic "maxItems" A_Lens Schema Schema a b where

480− labelOptic = #paramSchema % #maxItems

481− {-# INLINE labelOptic #-}

482−

483−instance

484− ( a ~ Maybe Integer, b ~ Maybe Integer

485− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where

486− labelOptic = #paramSchema % #maxItems

487− {-# INLINE labelOptic #-}

488−

489−instance

490− ( a ~ Maybe Integer, b ~ Maybe Integer

491− ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

492− labelOptic = #paramSchema % #maxItems

493− {-# INLINE labelOptic #-}

494−

495−-- #minItems

496−

497−instance

498− ( a ~ Maybe Integer, b ~ Maybe Integer

499− ) => LabelOptic "minItems" A_Lens Header Header a b where

500− labelOptic = #paramSchema % #minItems

501− {-# INLINE labelOptic #-}

502−

503−instance

504− ( a ~ Maybe Integer, b ~ Maybe Integer

505− ) => LabelOptic "minItems" A_Lens Schema Schema a b where

506− labelOptic = #paramSchema % #minItems

507− {-# INLINE labelOptic #-}

508−

509−instance

510− ( a ~ Maybe Integer, b ~ Maybe Integer

511− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where

512− labelOptic = #paramSchema % #minItems

513− {-# INLINE labelOptic #-}

514−

515−instance

516− ( a ~ Maybe Integer, b ~ Maybe Integer

517− ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

518− labelOptic = #paramSchema % #minItems

519− {-# INLINE labelOptic #-}

520−

521−-- #uniqueItems

522−

523−instance

524− ( a ~ Maybe Bool, b ~ Maybe Bool

525− ) => LabelOptic "uniqueItems" A_Lens Header Header a b where

526− labelOptic = #paramSchema % #uniqueItems

527− {-# INLINE labelOptic #-}

528−

529−instance

530− ( a ~ Maybe Bool, b ~ Maybe Bool

531− ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where

532− labelOptic = #paramSchema % #uniqueItems

533− {-# INLINE labelOptic #-}

534−

535−instance

536− ( a ~ Maybe Bool, b ~ Maybe Bool

537− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where

538− labelOptic = #paramSchema % #uniqueItems

539− {-# INLINE labelOptic #-}

540−

541−instance

542− ( a ~ Maybe Bool, b ~ Maybe Bool

543− ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

544− labelOptic = #paramSchema % #uniqueItems

545− {-# INLINE labelOptic #-}

546−

547−-- #enum

548−

549−instance

550− ( a ~ Maybe [Value], b ~ Maybe [Value]

551− ) => LabelOptic "enum" A_Lens Header Header a b where

552− labelOptic = #paramSchema % #enum

553− {-# INLINE labelOptic #-}

554−

555−instance

556− ( a ~ Maybe [Value], b ~ Maybe [Value]

557− ) => LabelOptic "enum" A_Lens Schema Schema a b where

558− labelOptic = #paramSchema % #enum

559− {-# INLINE labelOptic #-}

560−

561−instance

562− ( a ~ Maybe [Value], b ~ Maybe [Value]

563− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where

564− labelOptic = #paramSchema % #enum

565− {-# INLINE labelOptic #-}

566−

567−instance

568− ( a ~ Maybe [Value], b ~ Maybe [Value]

569− ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where

570− labelOptic = #paramSchema % #enum

571− {-# INLINE labelOptic #-}

572−

573−-- #multipleOf

574−

575−instance

576− ( a ~ Maybe Scientific, b ~ Maybe Scientific

577− ) => LabelOptic "multipleOf" A_Lens Header Header a b where

578− labelOptic = #paramSchema % #multipleOf

579− {-# INLINE labelOptic #-}

580−

581−instance

582− ( a ~ Maybe Scientific, b ~ Maybe Scientific

583− ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where

584− labelOptic = #paramSchema % #multipleOf

585− {-# INLINE labelOptic #-}

586−

587−instance

588− ( a ~ Maybe Scientific, b ~ Maybe Scientific

589− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where

590− labelOptic = #paramSchema % #multipleOf

591− {-# INLINE labelOptic #-}

592−

593−instance

594− ( a ~ Maybe Scientific, b ~ Maybe Scientific

595− ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where

596− labelOptic = #paramSchema % #multipleOf

597− {-# INLINE labelOptic #-}

src/Data/Swagger/Schema.hs−15

@@ -17,25 +17,11 @@ module Data.Swagger.Schema (

1717 -- * Generic schema encoding

1818 genericDeclareNamedSchema,

1919 genericDeclareSchema,

20− genericDeclareNamedSchemaNewtype,

21− genericNameSchema,

22−

23− -- ** 'Bounded' 'Integral'

2420 genericToNamedSchemaBoundedIntegral,

2521 toSchemaBoundedIntegral,

26−

27− -- ** 'Bounded' 'Enum' key mappings

28− declareSchemaBoundedEnumKeyMapping,

29− toSchemaBoundedEnumKeyMapping,

30−

31− -- ** Reusing 'ToParamSchema'

3222 paramSchemaToNamedSchema,

3323 paramSchemaToSchema,

3424

35− -- ** Unrestricted versions

36− genericDeclareNamedSchemaUnrestricted,

37− genericDeclareSchemaUnrestricted,

38−

3925 -- * Schema templates

4026 passwordSchema,

4127 binarySchema,

@@ -54,7 +40,6 @@ module Data.Swagger.Schema (

5440 -- * Generic encoding configuration

5541 SchemaOptions(..),

5642 defaultSchemaOptions,

57− fromAesonOptions,

5843) where

5944

6045import Data.Swagger.Internal.Schema

src/Data/Swagger/Schema/Generator.hsdeleted−114

@@ -1,114 +0,0 @@

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE OverloadedLists #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Data.Swagger.Schema.Generator where

6−

7−import Prelude ()

8−import Prelude.Compat

9−

10−import Control.Lens.Operators

11−import Control.Monad (filterM)

12−import Data.Aeson

13−import Data.Aeson.Types

14−import qualified Data.HashMap.Strict.InsOrd as M

15−import Data.Maybe

16−import Data.Maybe

17−import Data.Proxy

18−import Data.Scientific

19−import qualified Data.Set as S

20−import Data.Swagger

21−import Data.Swagger.Declare

22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)

23−import qualified Data.Text as T

24−import qualified Data.Vector as V

25−import Test.QuickCheck (arbitrary)

26−import Test.QuickCheck.Gen

27−import Test.QuickCheck.Property

28−

29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30−-- and cannot be inferred.

31−schemaGen :: Definitions Schema -> Schema -> Gen Value

32−schemaGen _ schema

33− | Just cases <- schema ^. paramSchema . enum_ = elements cases

34−schemaGen defns schema =

35− case schema ^. type_ of

36− Nothing ->

37− case inferSchemaTypes schema of

38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

39− -- Gen is not MonadFail

40− _ -> error "unable to infer schema type"

41− Just SwaggerBoolean -> Bool <$> elements [True, False]

42− Just SwaggerNull -> pure Null

43− Just SwaggerNumber

44− | Just min <- schema ^. minimum_

45− , Just max <- schema ^. maximum_ ->

46− Number . fromFloatDigits <$>

47− choose (toRealFloat min, toRealFloat max :: Double)

48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

49− Just SwaggerInteger

50− | Just min <- schema ^. minimum_

51− , Just max <- schema ^. maximum_ ->

52− Number . fromInteger <$>

53− choose (truncate min, truncate max)

54− | otherwise -> Number . fromInteger <$> arbitrary

55− Just SwaggerArray

56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

57− | Just items <- schema ^. items ->

58− case items of

59− SwaggerItemsObject ref -> do

60− size <- getSize

61− let itemSchema = dereference defns ref

62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems

63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems

64− arrayLength <- choose (minLength', max minLength' maxLength')

65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema

66− return . Array $ V.fromList generatedArray

67− SwaggerItemsArray refs ->

68− let itemGens = schemaGen defns . dereference defns <$> refs

69− in fmap (Array . V.fromList) $ sequence itemGens

70− Just SwaggerString -> do

71− size <- getSize

72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

74− length <- choose (minLength', max minLength' maxLength')

75− str <- vectorOf length arbitrary

76− return . String $ T.pack str

77− Just SwaggerObject -> do

78− size <- getSize

79− let props = dereference defns <$> schema ^. properties

80− reqKeys = S.fromList $ schema ^. required

81− allKeys = S.fromList . M.keys $ schema ^. properties

82− optionalKeys = allKeys S.\\ reqKeys

83− minProps' = fromMaybe (length reqKeys) $

84− fromInteger <$> schema ^. minProperties

85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties

86− shuffledOptional <- shuffle $ S.toList optionalKeys

87− numProps <- choose (minProps', max minProps' maxProps')

88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional

89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props

90− let gens = schemaGen defns <$> presentProps

91− additionalGens <- case schema ^. additionalProperties of

92− Just (AdditionalPropertiesSchema addlSchema) -> do

93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary

94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

95− _ -> return []

96− x <- sequence $ gens <> additionalGens

97− return . Object $ M.toHashMap x

98− where

99− dereference :: Definitions a -> Referenced a -> a

100− dereference _ (Inline a) = a

101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

102−

103−genValue :: (ToSchema a) => Proxy a -> Gen Value

104−genValue p =

105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty

106− in schemaGen defs schema

107−

108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property

109−validateFromJSON p = forAll (genValue p) $

110− \val -> case parseEither parseJSON val of

111− Right (_ :: a) -> succeeded

112− Left err -> failed

113− { reason = err

114− }

src/Data/Swagger/Schema/Validation.hs+1−10

@@ -15,18 +15,9 @@ module Data.Swagger.Schema.Validation (

1515 -- $maybe

1616

1717 -- * JSON validation

18−

19− ValidationError,

20−

21− -- ** Using 'ToJSON' and 'ToSchema'

22− validatePrettyToJSON,

2318 validateToJSON,

2419 validateToJSONWithPatternChecker,

25− renderValidationErrors,

26−

27− -- ** Using 'Value' and 'Schema'

28− validateJSON,

29− validateJSONWithPatternChecker,

20+ ValidationError,

3021) where

3122

3223import Data.Swagger.Internal.Schema.Validation

src/Data/Swagger/SchemaOptions.hs−29

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

1−{-# LANGUAGE RecordWildCards #-}

21-- |

32-- Module: Data.Swagger.SchemaOptions

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

@@ -7,8 +6,6 @@

76-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.

87module Data.Swagger.SchemaOptions where

10−import qualified Data.Aeson.Types as Aeson

11−

129-- | Options that specify how to encode your type to Swagger schema.

1310data SchemaOptions = SchemaOptions

1411 { -- | Function applied to field labels. Handy for removing common record prefixes for example.

@@ -44,29 +41,3 @@ defaultSchemaOptions = SchemaOptions

4441 , unwrapUnaryRecords = False

4542 }

4643

47−-- | Convert 'Aeson.Options' to 'SchemaOptions'.

48−--

49−-- Specifically the following fields get copied:

50−--

51−-- * 'fieldLabelModifier'

52−-- * 'constructorTagModifier'

53−-- * 'allNullaryToStringTag'

54−-- * 'unwrapUnaryRecords'

55−--

56−-- Note that these fields have no effect on `SchemaOptions`:

57−--

58−-- * 'Aeson.omitNothingFields'

59−-- * 'Aeson.sumEncoding'

60−-- * 'Aeson.tagSingleConstructors'

61−--

62−-- The rest is defined as in 'defaultSchemaOptions'.

63−--

64−-- @since 2.2.1

65−--

66−fromAesonOptions :: Aeson.Options -> SchemaOptions

67−fromAesonOptions opts = defaultSchemaOptions

68− { fieldLabelModifier = Aeson.fieldLabelModifier opts

69− , constructorTagModifier = Aeson.constructorTagModifier opts

70− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts

71− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts

72− }

stack-ghc-8.0.yamlnew file+3

@@ -0,0 +1,3 @@

1+resolver: nightly-2016-05-29

2+packages:

3+- '.'

stack-lts-2.yamlnew file+8

@@ -0,0 +1,8 @@

1+flags: {}

2+packages:

3+- '.'

4+extra-deps:

5+- generics-sop-0.2.1.0

6+- insert-ordered-containers-0.1.0.1

7+- unordered-containers-0.2.7.0

8+resolver: lts-2.22

stack.yaml+4−6

@@ -1,9 +1,7 @@

1−resolver: lts-14.3

1+flags: {}

22packages:

33- '.'

44extra-deps:

5−- optics-core-0.2

6−- optics-th-0.2

7−- optics-extra-0.2

8−- indexed-profunctors-0.1

9−- insert-ordered-containers-0.2.3

5+- aeson-1.0.0.0

6+- insert-ordered-containers-0.2.0.0

7+resolver: nightly-2016-07-15

swagger2.cabal+45−97

@@ -1,15 +1,7 @@

1−cabal-version: >=1.10

21name: swagger2

3−version: 2.5

4−

2+version: 2.1.2

53synopsis: Swagger 2.0 data model

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−

4+description: Please see README.md

135homepage: https://github.com/GetShopTV/swagger2

146bug-reports: https://github.com/GetShopTV/swagger2/issues

157license: BSD3

@@ -17,22 +9,15 @@ license-file: LICENSE

179author: Nickolay Kudasov

1810maintainer: nickolay@getshoptv.com

20−build-type: Custom

12+category: Web

13+build-type: Simple

2114extra-source-files:

2215 README.md

2316 , CHANGELOG.md

2417 , examples/*.hs

2518 , include/overlapping-compat.h

26−tested-with:

27− GHC ==8.0.2

28− || ==8.2.2

29− || ==8.4.4

30− || ==8.6.5

31− || ==8.8.1

32−

33−custom-setup

34− setup-depends:

35− base, Cabal, cabal-doctest >=1.0.6 && <1.1

19+cabal-version: >=1.10

20+tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1

3621

3722library

3823 hs-source-dirs: src

@@ -42,10 +27,8 @@ library

4227 Data.Swagger.Declare

4328 Data.Swagger.Lens

4429 Data.Swagger.Operation

45− Data.Swagger.Optics

4630 Data.Swagger.ParamSchema

4731 Data.Swagger.Schema

48− Data.Swagger.Schema.Generator

4932 Data.Swagger.Schema.Validation

5033 Data.Swagger.SchemaOptions

5134

@@ -56,97 +39,62 @@ library

5639 Data.Swagger.Internal.ParamSchema

5740 Data.Swagger.Internal.Utils

5841 Data.Swagger.Internal.AesonUtils

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−

42+ build-depends: base >=4.7 && <4.10

43+ , base-compat >=0.6.0 && <0.10

44+ , aeson

45+ , containers

46+ , hashable

47+ , generics-sop >=0.2 && <0.3

48+ , http-media

49+ , insert-ordered-containers >=0.1.0.0 && <0.3

50+ , lens

51+ , mtl

52+ , network

53+ , scientific

54+ , text

55+ , template-haskell

56+ , time

57+ , transformers

58+ , unordered-containers

59+ , vector

9660 default-language: Haskell2010

9761

9862test-suite spec

9963 type: exitcode-stdio-1.0

10064 hs-source-dirs: test

10165 main-is: Spec.hs

102−

103− -- From library parat

10466 -- We need aeson's toEncoding for doctests too

105− build-depends:

106− base

107− , swagger2

108− , aeson

109− , base-compat-batteries

110− , bytestring

111− , containers

112− , hashable

113− , insert-ordered-containers

114− , lens

115− , mtl

116− , template-haskell

117− , text

118− , time

119− , unordered-containers

120− , vector

121− , QuickCheck

122−

123− -- test-suite only dependencies

124− build-depends:

125− hspec >=2.5.5 && <2.8

126− , HUnit >=1.6.0.0 && <1.7

127− , quickcheck-instances >=0.3.19 && <0.14

128− , utf8-string >=1.0.1.1 && <1.1

129−

130− -- https://github.com/haskell/cabal/issues/3708

131− build-tool-depends:

132− hspec-discover:hspec-discover >=2.5.5 && <2.8

133−

67+ build-depends: base

68+ , base-compat

69+ , aeson >=0.10.0.0

70+ , aeson-qq

71+ , bytestring

72+ , containers

73+ , hashable

74+ , hspec

75+ , insert-ordered-containers

76+ , HUnit

77+ , mtl

78+ , QuickCheck

79+ , swagger2

80+ , text

81+ , time

82+ , unordered-containers

83+ , vector

84+ , lens

13485 other-modules:

13586 SpecCommon

13687 Data.SwaggerSpec

137− Data.Swagger.CommonTestTypes

13888 Data.Swagger.ParamSchemaSpec

13989 Data.Swagger.SchemaSpec

14090 Data.Swagger.Schema.ValidationSpec

141− Data.Swagger.Schema.GeneratorSpec

14291 default-language: Haskell2010

14392

144−test-suite doctests

145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes

146− build-depends: base, doctest, Glob, QuickCheck

93+test-suite doctest

94+ build-depends: base, doctest, Glob

14795 default-language: Haskell2010

14896 hs-source-dirs: test

149− main-is: doctests.hs

97+ main-is: DocTest.hs

15098 type: exitcode-stdio-1.0

15199

152100source-repository head

test/Data/Swagger/CommonTestTypes.hsdeleted−679

@@ -1,679 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE QuasiQuotes #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Data.Swagger.CommonTestTypes where

6−

7−import Prelude ()

8−import Prelude.Compat

9−

10−import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)

11−import Data.Aeson.QQ.Simple

12−import Data.Aeson.Types (toJSONKeyText)

13−import Data.Char

14−import Data.Map (Map)

15−import Data.Proxy

16−import Data.Set (Set)

17−import qualified Data.Text as Text

18−import GHC.Generics

19−

20−import Data.Swagger

21−

22−-- ========================================================================

23−-- Unit type

24−-- ========================================================================

25−

26−data Unit = Unit deriving (Generic)

27−instance ToParamSchema Unit

28−instance ToSchema Unit

29−

30−unitSchemaJSON :: Value

31−unitSchemaJSON = [aesonQQ|

32−{

33− "type": "string",

34− "enum": ["Unit"]

35−}

36−|]

37−

38−-- ========================================================================

39−-- Color (enum)

40−-- ========================================================================

41−data Color

42− = Red

43− | Green

44− | Blue

45− deriving (Generic)

46−instance ToParamSchema Color

47−instance ToSchema Color

48−

49−colorSchemaJSON :: Value

50−colorSchemaJSON = [aesonQQ|

51−{

52− "type": "string",

53− "enum": ["Red", "Green", "Blue"]

54−}

55−|]

56−

57−-- ========================================================================

58−-- Shade (paramSchemaToNamedSchema)

59−-- ========================================================================

60−

61−data Shade = Dim | Bright deriving (Generic)

62−instance ToParamSchema Shade

63−

64−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions

65−

66−shadeSchemaJSON :: Value

67−shadeSchemaJSON = [aesonQQ|

68−{

69− "type": "string",

70− "enum": ["Dim", "Bright"]

71−}

72−|]

73−

74−-- ========================================================================

75−-- Paint (record with bounded enum property)

76−-- ========================================================================

77−

78−newtype Paint = Paint { color :: Color }

79− deriving (Generic)

80−instance ToSchema Paint

81−

82−paintSchemaJSON :: Value

83−paintSchemaJSON = [aesonQQ|

84−{

85− "type": "object",

86− "properties":

87− {

88− "color":

89− {

90− "$ref": "#/definitions/Color"

91− }

92− },

93− "required": ["color"]

94−}

95−|]

96−

97−paintInlinedSchemaJSON :: Value

98−paintInlinedSchemaJSON = [aesonQQ|

99−{

100− "type": "object",

101− "properties":

102− {

103− "color":

104− {

105− "type": "string",

106− "enum": ["Red", "Green", "Blue"]

107− }

108− },

109− "required": ["color"]

110−}

111−|]

112−

113−-- ========================================================================

114−-- Status (constructorTagModifier)

115−-- ========================================================================

116−

117−data Status

118− = StatusOk

119− | StatusError

120− deriving (Generic)

121−

122−instance ToParamSchema Status where

123− toParamSchema = genericToParamSchema defaultSchemaOptions

124− { constructorTagModifier = map toLower . drop (length "Status") }

125−instance ToSchema Status where

126− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

127− { constructorTagModifier = map toLower . drop (length "Status") }

128−

129−statusSchemaJSON :: Value

130−statusSchemaJSON = [aesonQQ|

131−{

132− "type": "string",

133− "enum": ["ok", "error"]

134−}

135−|]

136−

137−-- ========================================================================

138−-- Email (newtype with unwrapUnaryRecords set to True)

139−-- ========================================================================

140−

141−newtype Email = Email { getEmail :: String }

142− deriving (Generic)

143−instance ToParamSchema Email

144−instance ToSchema Email where

145− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

146− { unwrapUnaryRecords = True }

147−

148−emailSchemaJSON :: Value

149−emailSchemaJSON = [aesonQQ|

150−{

151− "type": "string"

152−}

153−|]

154−

155−-- ========================================================================

156−-- UserId (non-record newtype)

157−-- ========================================================================

158−

159−newtype UserId = UserId Integer

160− deriving (Eq, Ord, Generic)

161−instance ToParamSchema UserId

162−instance ToSchema UserId

163−

164−userIdSchemaJSON :: Value

165−userIdSchemaJSON = [aesonQQ|

166−{

167− "type": "integer"

168−}

169−|]

170−

171−-- ========================================================================

172−-- UserGroup (set newtype)

173−-- ========================================================================

174−

175−newtype UserGroup = UserGroup (Set UserId)

176− deriving (Generic)

177−instance ToSchema UserGroup

178−

179−userGroupSchemaJSON :: Value

180−userGroupSchemaJSON = [aesonQQ|

181−{

182− "type": "array",

183− "items": { "$ref": "#/definitions/UserId" },

184− "uniqueItems": true

185−}

186−|]

187−

188−-- ========================================================================

189−-- Person (simple record with optional fields)

190−-- ========================================================================

191−data Person = Person

192− { name :: String

193− , phone :: Integer

194− , email :: Maybe String

195− } deriving (Generic)

196−

197−instance ToSchema Person

198−

199−personSchemaJSON :: Value

200−personSchemaJSON = [aesonQQ|

201−{

202− "type": "object",

203− "properties":

204− {

205− "name": { "type": "string" },

206− "phone": { "type": "integer" },

207− "email": { "type": "string" }

208− },

209− "required": ["name", "phone"]

210−}

211−|]

212−

213−-- ========================================================================

214−-- Player (record newtype)

215−-- ========================================================================

216−

217−newtype Player = Player

218− { position :: Point

219− } deriving (Generic)

220−instance ToSchema Player

221−

222−playerSchemaJSON :: Value

223−playerSchemaJSON = [aesonQQ|

224−{

225− "type": "object",

226− "properties":

227− {

228− "position":

229− {

230− "$ref": "#/definitions/Point"

231− }

232− },

233− "required": ["position"]

234−}

235−|]

236−

237−newtype Players = Players [Inlined Player]

238− deriving (Generic)

239−instance ToSchema Players

240−

241−playersSchemaJSON :: Value

242−playersSchemaJSON = [aesonQQ|

243−{

244− "type": "array",

245− "items":

246− {

247− "type": "object",

248− "properties":

249− {

250− "position":

251− {

252− "$ref": "#/definitions/Point"

253− }

254− },

255− "required": ["position"]

256− }

257−}

258−|]

259−

260−-- ========================================================================

261−-- Character (sum type with ref and record in alternative)

262−-- ========================================================================

263−

264−data Character

265− = PC Player

266− | NPC { npcName :: String, npcPosition :: Point }

267− deriving (Generic)

268−instance ToSchema Character

269−

270−characterSchemaJSON :: Value

271−characterSchemaJSON = [aesonQQ|

272−{

273− "type": "object",

274− "properties":

275− {

276− "PC": { "$ref": "#/definitions/Player" },

277− "NPC":

278− {

279− "type": "object",

280− "properties":

281− {

282− "npcName": { "type": "string" },

283− "npcPosition": { "$ref": "#/definitions/Point" }

284− },

285− "required": ["npcName", "npcPosition"]

286− }

287− },

288− "maxProperties": 1,

289− "minProperties": 1

290−}

291−|]

292−

293−characterInlinedSchemaJSON :: Value

294−characterInlinedSchemaJSON = [aesonQQ|

295−{

296− "type": "object",

297− "properties":

298− {

299− "PC":

300− {

301− "type": "object",

302− "properties":

303− {

304− "position":

305− {

306− "type": "object",

307− "properties":

308− {

309− "x": { "type": "number", "format": "double" },

310− "y": { "type": "number", "format": "double" }

311− },

312− "required": ["x", "y"]

313− }

314− },

315− "required": ["position"]

316− },

317− "NPC":

318− {

319− "type": "object",

320− "properties":

321− {

322− "npcName": { "type": "string" },

323− "npcPosition":

324− {

325− "type": "object",

326− "properties":

327− {

328− "x": { "type": "number", "format": "double" },

329− "y": { "type": "number", "format": "double" }

330− },

331− "required": ["x", "y"]

332− }

333− },

334− "required": ["npcName", "npcPosition"]

335− }

336− },

337− "maxProperties": 1,

338− "minProperties": 1

339−}

340−|]

341−

342−characterInlinedPlayerSchemaJSON :: Value

343−characterInlinedPlayerSchemaJSON = [aesonQQ|

344−{

345− "type": "object",

346− "properties":

347− {

348− "PC":

349− {

350− "type": "object",

351− "properties":

352− {

353− "position":

354− {

355− "$ref": "#/definitions/Point"

356− }

357− },

358− "required": ["position"]

359− },

360− "NPC":

361− {

362− "type": "object",

363− "properties":

364− {

365− "npcName": { "type": "string" },

366− "npcPosition": { "$ref": "#/definitions/Point" }

367− },

368− "required": ["npcName", "npcPosition"]

369− }

370− },

371− "maxProperties": 1,

372− "minProperties": 1

373−}

374−|]

375−

376−-- ========================================================================

377−-- ISPair (non-record product data type)

378−-- ========================================================================

379−data ISPair = ISPair Integer String

380− deriving (Generic)

381−

382−instance ToSchema ISPair

383−

384−ispairSchemaJSON :: Value

385−ispairSchemaJSON = [aesonQQ|

386−{

387− "type": "array",

388− "items":

389− [

390− { "type": "integer" },

391− { "type": "string" }

392− ],

393− "minItems": 2,

394− "maxItems": 2

395−}

396−|]

397−

398−-- ========================================================================

399−-- Point (record data type with custom fieldLabelModifier)

400−-- ========================================================================

401−

402−data Point = Point

403− { pointX :: Double

404− , pointY :: Double

405− } deriving (Generic)

406−

407−instance ToSchema Point where

408− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

409− { fieldLabelModifier = map toLower . drop (length "point") }

410−

411−pointSchemaJSON :: Value

412−pointSchemaJSON = [aesonQQ|

413−{

414− "type": "object",

415− "properties":

416− {

417− "x": { "type": "number", "format": "double" },

418− "y": { "type": "number", "format": "double" }

419− },

420− "required": ["x", "y"]

421−}

422−|]

423−

424−-- ========================================================================

425−-- Point (record data type with multiple fields)

426−-- ========================================================================

427−

428−data Point5 = Point5

429− { point5X :: Double

430− , point5Y :: Double

431− , point5Z :: Double

432− , point5U :: Double

433− , point5V :: Double -- 5 dimensional!

434− } deriving (Generic)

435−

436−instance ToSchema Point5 where

437− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

438− { fieldLabelModifier = map toLower . drop (length "point5") }

439−

440−point5SchemaJSON :: Value

441−point5SchemaJSON = [aesonQQ|

442−{

443− "type": "object",

444− "properties":

445− {

446− "x": { "type": "number", "format": "double" },

447− "y": { "type": "number", "format": "double" },

448− "z": { "type": "number", "format": "double" },

449− "u": { "type": "number", "format": "double" },

450− "v": { "type": "number", "format": "double" }

451− },

452− "required": ["x", "y", "z", "u", "v"]

453−}

454−|]

455−

456−point5Properties :: [String]

457−point5Properties = ["x", "y", "z", "u", "v"]

458−

459−-- ========================================================================

460−-- MyRoseTree (custom datatypeNameModifier)

461−-- ========================================================================

462−

463−data MyRoseTree = MyRoseTree

464− { root :: String

465− , trees :: [MyRoseTree]

466− } deriving (Generic)

467−

468−instance ToSchema MyRoseTree where

469− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

470− { datatypeNameModifier = drop (length "My") }

471−

472−myRoseTreeSchemaJSON :: Value

473−myRoseTreeSchemaJSON = [aesonQQ|

474−{

475− "type": "object",

476− "properties":

477− {

478− "root": { "type": "string" },

479− "trees":

480− {

481− "type": "array",

482− "items":

483− {

484− "$ref": "#/definitions/RoseTree"

485− }

486− }

487− },

488− "required": ["root", "trees"]

489−}

490−|]

491−

492−data MyRoseTree' = MyRoseTree'

493− { root' :: String

494− , trees' :: [MyRoseTree']

495− } deriving (Generic)

496−

497−instance ToSchema MyRoseTree' where

498− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

499− { datatypeNameModifier = map toLower }

500−

501−myRoseTreeSchemaJSON' :: Value

502−myRoseTreeSchemaJSON' = [aesonQQ|

503−{

504− "type": "object",

505− "properties":

506− {

507− "root'": { "type": "string" },

508− "trees'":

509− {

510− "type": "array",

511− "items":

512− {

513− "$ref": "#/definitions/myrosetree'"

514− }

515− }

516− },

517− "required": ["root'", "trees'"]

518−}

519−|]

520−

521−-- ========================================================================

522−-- Inlined (newtype for inlining schemas)

523−-- ========================================================================

524−

525−newtype Inlined a = Inlined { getInlined :: a }

526−

527−instance ToSchema a => ToSchema (Inlined a) where

528− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

529− where

530− unname (NamedSchema _ s) = NamedSchema Nothing s

531−

532−-- ========================================================================

533−-- Light (sum type with unwrapUnaryRecords)

534−-- ========================================================================

535−

536−data Light

537− = NoLight

538− | LightFreq Double

539− | LightColor Color

540− | LightWaveLength { waveLength :: Double }

541− deriving (Generic)

542−

543−instance ToSchema Light where

544− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

545− { unwrapUnaryRecords = True }

546−

547−lightSchemaJSON :: Value

548−lightSchemaJSON = [aesonQQ|

549−{

550− "type": "object",

551− "properties":

552− {

553− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

554− "LightFreq": { "type": "number", "format": "double" },

555− "LightColor": { "$ref": "#/definitions/Color" },

556− "LightWaveLength": { "type": "number", "format": "double" }

557− },

558− "maxProperties": 1,

559− "minProperties": 1

560−}

561−|]

562−

563−lightInlinedSchemaJSON :: Value

564−lightInlinedSchemaJSON = [aesonQQ|

565−{

566− "type": "object",

567− "properties":

568− {

569− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

570− "LightFreq": { "type": "number", "format": "double" },

571− "LightColor":

572− {

573− "type": "string",

574− "enum": ["Red", "Green", "Blue"]

575− },

576− "LightWaveLength": { "type": "number", "format": "double" }

577− },

578− "maxProperties": 1,

579− "minProperties": 1

580−}

581−|]

582−

583−-- ========================================================================

584−-- ResourceId (series of newtypes)

585−-- ========================================================================

586−

587−newtype Id = Id String deriving (Generic)

588−instance ToSchema Id

589−

590−newtype ResourceId = ResourceId Id deriving (Generic)

591−instance ToSchema ResourceId

592−

593−-- ========================================================================

594−-- ButtonImages (bounded enum key mapping)

595−-- ========================================================================

596−

597−data ButtonState = Neutral | Focus | Active | Hover | Disabled

598− deriving (Show, Bounded, Enum, Generic)

599−

600−instance ToJSON ButtonState

601−instance ToSchema ButtonState

602−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)

603−

604−type ImageUrl = Text.Text

605−

606−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

607− deriving (Generic)

608−

609−instance ToJSON ButtonImages where

610− toJSON = toJSON . getButtonImages

611−

612−instance ToSchema ButtonImages where

613− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

614− declareSchemaBoundedEnumKeyMapping

615−

616−buttonImagesSchemaJSON :: Value

617−buttonImagesSchemaJSON = [aesonQQ|

618−{

619− "type": "object",

620− "properties":

621− {

622− "Neutral": { "type": "string" },

623− "Focus": { "type": "string" },

624− "Active": { "type": "string" },

625− "Hover": { "type": "string" },

626− "Disabled": { "type": "string" }

627− }

628−}

629−|]

630−

631−-- ========================================================================

632−-- SingleMaybeField (single field data with optional field)

633−-- ========================================================================

634−

635−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }

636− deriving (Show, Generic)

637−

638−instance ToJSON SingleMaybeField

639−instance ToSchema SingleMaybeField

640−

641−singleMaybeFieldSchemaJSON :: Value

642−singleMaybeFieldSchemaJSON = [aesonQQ|

643−{

644− "type": "object",

645− "properties":

646− {

647− "singleMaybeField": { "type": "string" }

648− }

649−}

650−|]

651−

652−

653−-- ========================================================================

654−-- TimeOfDay

655−-- ========================================================================

656−data TimeOfDay

657− = Int

658− | Pico

659− deriving (Generic)

660−instance ToSchema TimeOfDay

661−instance ToParamSchema TimeOfDay

662−

663−

664−timeOfDaySchemaJSON :: Value

665−timeOfDaySchemaJSON = [aesonQQ|

666−{

667− "example": "12:33:15",

668− "type": "string",

669− "format": "hh:MM:ss"

670−}

671−|]

672−

673−timeOfDayParamSchemaJSON :: Value

674−timeOfDayParamSchemaJSON = [aesonQQ|

675−{

676− "type": "string",

677− "format": "hh:MM:ss"

678−}

679−|]

test/Data/Swagger/ParamSchemaSpec.hs+84−8

@@ -3,11 +3,10 @@

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE TemplateHaskell #-}

55{-# LANGUAGE QuasiQuotes #-}

6−{-# LANGUAGE OverloadedStrings #-}

76module Data.Swagger.ParamSchemaSpec where

98import Data.Aeson

10−import Data.Aeson.QQ.Simple

9+import Data.Aeson.QQ

1110import Data.Char

1211import Data.Proxy

1312import GHC.Generics

@@ -15,15 +14,11 @@ import GHC.Generics

1514import Data.Swagger

1615import Data.Swagger.Internal (SwaggerKind(..))

1716

18−import Data.Swagger.CommonTestTypes

1917import SpecCommon

2018import Test.Hspec

21−import Data.Time.LocalTime

22−

23−import qualified Data.HashMap.Strict as HM

2419

2520checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

21+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema (SwaggerKindNormal Param)) <=> js

2722

2823spec :: Spec

2924spec = do

@@ -34,7 +29,88 @@ spec = do

3429 context "Unary records" $ do

3530 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

3631 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

3832

3933main :: IO ()

4034main = hspec spec

35+

36+-- ========================================================================

37+-- Unit type

38+-- ========================================================================

39+

40+data Unit = Unit deriving (Generic)

41+instance ToParamSchema Unit

42+

43+unitSchemaJSON :: Value

44+unitSchemaJSON = [aesonQQ|

45+{

46+ "type": "string",

47+ "enum": ["Unit"]

48+}

49+|]

50+

51+-- ========================================================================

52+-- Color (enum)

53+-- ========================================================================

54+data Color

55+ = Red

56+ | Green

57+ | Blue

58+ deriving (Generic)

59+instance ToParamSchema Color

60+

61+colorSchemaJSON :: Value

62+colorSchemaJSON = [aesonQQ|

63+{

64+ "type": "string",

65+ "enum": ["Red", "Green", "Blue"]

66+}

67+|]

68+

69+-- ========================================================================

70+-- Status (constructorTagModifier)

71+-- ========================================================================

72+

73+data Status = StatusOk | StatusError deriving (Generic)

74+

75+instance ToParamSchema Status where

76+ toParamSchema = genericToParamSchema defaultSchemaOptions

77+ { constructorTagModifier = map toLower . drop (length "Status") }

78+

79+statusSchemaJSON :: Value

80+statusSchemaJSON = [aesonQQ|

81+{

82+ "type": "string",

83+ "enum": ["ok", "error"]

84+}

85+|]

86+

87+-- ========================================================================

88+-- Email (newtype with unwrapUnaryRecords set to True)

89+-- ========================================================================

90+

91+newtype Email = Email { getEmail :: String }

92+ deriving (Generic)

93+instance ToParamSchema Email

94+

95+emailSchemaJSON :: Value

96+emailSchemaJSON = [aesonQQ|

97+{

98+ "type": "string"

99+}

100+|]

101+

102+-- ========================================================================

103+-- UserId (non-record newtype)

104+-- ========================================================================

105+

106+newtype UserId = UserId Integer

107+ deriving (Generic)

108+instance ToParamSchema UserId

109+

110+userIdSchemaJSON :: Value

111+userIdSchemaJSON = [aesonQQ|

112+{

113+ "type": "integer"

114+}

115+|]

116+

test/Data/Swagger/Schema/GeneratorSpec.hsdeleted−168

@@ -1,168 +0,0 @@

1−{-# LANGUAGE OverloadedLists #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE PackageImports #-}

4−module Data.Swagger.Schema.GeneratorSpec where

5−

6−import Prelude ()

7−import Prelude.Compat

8−

9−import Data.Swagger

10−import Data.Swagger.Schema.Generator

11−

12−import Control.Lens.Operators

13−import Data.Aeson

14−import Data.Hashable (Hashable)

15−import Data.HashMap.Strict (HashMap)

16−import qualified Data.HashMap.Strict as HashMap

17−import "unordered-containers" Data.HashSet (HashSet)

18−import qualified "unordered-containers" Data.HashSet as HashSet

19−import Data.Int

20−import Data.IntMap (IntMap)

21−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

22−import Data.Map (Map, fromList)

23−import Data.Monoid (mempty)

24−import Data.Proxy

25−import Data.Proxy

26−import Data.Set (Set)

27−import qualified Data.Text as T

28−import qualified Data.Text.Lazy as TL

29−import Data.Time

30−import Data.Version (Version)

31−import Data.Word

32−import GHC.Generics

33−

34−import Test.Hspec

35−import Test.Hspec.QuickCheck

36−import Test.QuickCheck

37−

38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

39−shouldValidate = validateFromJSON

40−

41−

42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

43−shouldNotValidate = expectFailure . shouldValidate

44−

45−

46−spec :: Spec

47−spec = do

48− describe "FromJSON validation" $ do

49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)

50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)

51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)

52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)

53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)

54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)

55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)

56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)

57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)

58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)

59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)

60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)

61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)

62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)

63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)

64− prop "String" $ shouldValidate (Proxy :: Proxy String)

65− prop "()" $ shouldValidate (Proxy :: Proxy ())

66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)

67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)

68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)

69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)

70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])

71− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

74− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))

79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))

80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))

81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

82− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

83− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

84− prop "Object" $ shouldValidate (Proxy :: Proxy Object)

85− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

86− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

87− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

88− describe "Invalid FromJSON validation" $ do

89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)

90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)

91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)

92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)

93−

94−-- =============================

95−-- Data types and bunk instances

96−-- =============================

97−

98−data WrongType = WrongType Bool

99−

100−instance FromJSON WrongType where

101− parseJSON = withBool "WrongType" $ return . WrongType

102−

103−instance ToSchema WrongType where

104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $

105− mempty

106− & type_ ?~ SwaggerObject

107−

108−

109−data MissingRequired = MissingRequired

110− { propA :: String

111− , propB :: Bool

112− }

113−

114−instance FromJSON MissingRequired where

115− parseJSON = withObject "MissingRequired" $ \o ->

116− MissingRequired

117− <$> o .: "propA"

118− <*> o .: "propB"

119−

120−instance ToSchema MissingRequired where

121− declareNamedSchema _ = do

122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)

123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

124− return . NamedSchema (Just "MissingRequired") $

125− mempty

126− & type_ ?~ SwaggerObject

127− & properties .~ [("propA", stringSchema)

128− ,("propB", boolSchema)

129− ]

130− & required .~ ["propA"]

131−

132−data MissingProperty = MissingProperty

133− { propC :: String

134− , propD :: Bool

135− }

136−

137−instance FromJSON MissingProperty where

138− parseJSON = withObject "MissingProperty" $ \o ->

139− MissingProperty

140− <$> o .: "propC"

141− <*> o .: "propD"

142−

143−instance ToSchema MissingProperty where

144− declareNamedSchema _ = do

145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)

146− return . NamedSchema (Just "MissingProperty") $

147− mempty

148− & type_ ?~ SwaggerObject

149− & properties .~ [("propC", stringSchema)]

150− & required .~ ["propC"]

151−

152−data WrongPropType = WrongPropType

153− { propE :: String

154− }

155−

156−instance FromJSON WrongPropType where

157− parseJSON = withObject "WrongPropType" $ \o ->

158− WrongPropType

159− <$> o .: "propE"

160−

161−instance ToSchema WrongPropType where

162− declareNamedSchema _ = do

163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

164− return . NamedSchema (Just "WrongPropType") $

165− mempty

166− & type_ ?~ SwaggerObject

167− & properties .~ [("propE", boolSchema)]

168− & required .~ ["propE"]

test/Data/Swagger/Schema/ValidationSpec.hs+65−130

@@ -1,50 +1,43 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE PackageImports #-}

4−{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# OPTIONS_GHC -fno-warn-orphans #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE PackageImports #-}

74module Data.Swagger.Schema.ValidationSpec where

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)

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)

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

18−import Data.Int

19−import Data.IntMap (IntMap)

20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

21−import Data.Map (Map, fromList)

22−import Data.Monoid (mempty)

23−import Data.Proxy

24−import Data.Set (Set)

25−import qualified Data.Text as T

26−import qualified Data.Text.Lazy as TL

27−import Data.Time

28−import Data.Version (Version)

29−import Data.Word

30−import GHC.Generics

31−

32−import Data.Swagger

33−import Data.Swagger.Declare

34−

35−import Test.Hspec

36−import Test.Hspec.QuickCheck

37−import Test.QuickCheck

38−import Test.QuickCheck.Instances ()

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

3937

4038shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

4139shouldValidate _ x = validateToJSON x == []

4240

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−

4841spec :: Spec

4942spec = do

5043 describe "Validation" $ do

@@ -73,7 +66,6 @@ spec = do

7366 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

7467 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

7568 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

7769 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

7870 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

7971 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

@@ -83,7 +75,6 @@ spec = do

8375 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

8476 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

8577 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)

8778 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

8879 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

8980 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

@@ -92,16 +83,6 @@ spec = do

9283 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

9384 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

9485 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

10586

10687main :: IO ()

10788main = hspec spec

@@ -121,13 +102,6 @@ instance ToSchema Person

121102instance Arbitrary Person where

122103 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

123104

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−

131105-- ========================================================================

132106-- Color (enum)

133107-- ========================================================================

@@ -139,11 +113,6 @@ instance ToSchema Color

139113instance Arbitrary Color where

140114 arbitrary = arbitraryBoundedEnum

141115

142−invalidColorToJSON :: Color -> Value

143−invalidColorToJSON Red = toJSON "red"

144−invalidColorToJSON Green = toJSON "green"

145−invalidColorToJSON Blue = toJSON "blue"

146−

147116-- ========================================================================

148117-- Paint (record with bounded enum property)

149118-- ========================================================================

@@ -157,9 +126,6 @@ instance ToSchema Paint

157126instance Arbitrary Paint where

158127 arbitrary = Paint <$> arbitrary

159128

160−invalidPaintToJSON :: Paint -> Value

161−invalidPaintToJSON = toJSON . color

162−

163129-- ========================================================================

164130-- MyRoseTree (custom datatypeNameModifier)

165131-- ========================================================================

@@ -188,8 +154,7 @@ instance Arbitrary MyRoseTree where

188154

189155data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)

190156

191−instance ToSchema Light where

192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

157+instance ToSchema Light

193158

194159instance ToJSON Light where

195160 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

@@ -201,78 +166,48 @@ instance Arbitrary Light where

201166 , LightColor <$> arbitrary

202167 ]

203168

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

169+-- Arbitrary instances for common types

222170

223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

224− deriving (Show, Generic)

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

225175

226−instance ToJSON ButtonImages where

227− toJSON = toJSON . getButtonImages

176+instance Arbitrary a => Arbitrary (IntMap a) where

177+ arbitrary = IntMap.fromList <$> arbitrary

228178

229−instance ToSchema ButtonImages where

230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

231− declareSchemaBoundedEnumKeyMapping

179+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where

180+ arbitrary = Set.fromList <$> arbitrary

181+#endif

232182

233−invalidButtonImagesToJSON :: ButtonImages -> Value

234−invalidButtonImagesToJSON = genericToJSON defaultOptions

183+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

184+ arbitrary = HashMap.fromList <$> arbitrary

235185

236−instance Arbitrary ButtonImages where

237− arbitrary = ButtonImages <$> arbitrary

186+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where

187+ arbitrary = HashSet.fromList <$> arbitrary

238188

239−-- ========================================================================

240−-- FreeForm (wraps a raw JSON Value)

241−-- ========================================================================

189+instance Arbitrary T.Text where

190+ arbitrary = T.pack <$> arbitrary

242191

243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }

244− deriving (Show, Generic)

192+instance Arbitrary TL.Text where

193+ arbitrary = TL.pack <$> arbitrary

245194

246−instance ToJSON FreeForm where

247− toJSON = toJSON . jsonContent

195+instance Arbitrary Day where

196+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary

248197

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)

198+instance Arbitrary LocalTime where

199+ arbitrary = LocalTime

200+ <$> arbitrary

201+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))

261202

262203instance Eq ZonedTime where

263204 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

264205

265−-- ========================================================================

266−-- Arbitrary instance for Data.Aeson.Value

267−-- ========================================================================

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

268213

269−instance Arbitrary Value where

270− -- Weights are almost random

271− -- Uniform oneof tends not to build complex objects cause of recursive call.

272− arbitrary = resize 4 $ frequency

273− [ (3, Object <$> arbitrary)

274− , (3, Array <$> arbitrary)

275− , (3, String <$> arbitrary)

276− , (3, Number <$> arbitrary)

277− , (3, Bool <$> arbitrary)

278− , (1, return Null) ]

test/Data/Swagger/SchemaSpec.hs+547−12

@@ -8,22 +8,23 @@ import Prelude ()

88import Prelude.Compat

1010import Control.Lens ((^.))

11−import Data.Aeson (Value)

11+import Data.Aeson

12+import Data.Aeson.QQ

13+import Data.Char

14+import qualified Data.HashMap.Strict as HashMap

1215import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

1316import Data.Proxy

1417import Data.Set (Set)

18+import qualified Data.Set as Set

1519import qualified Data.Text as Text

20+import GHC.Generics

1621

1722import Data.Swagger

1823import Data.Swagger.Declare

1924

20−import Data.Swagger.CommonTestTypes

2125import SpecCommon

2226import Test.Hspec

2327

24−import qualified Data.HashMap.Strict as HM

25−import Data.Time.LocalTime

26−

2728checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

2829checkToSchema proxy js = toSchema proxy <=> js

2930

@@ -77,10 +78,8 @@ spec = do

7778 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON

7879 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON

7980 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON

80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON

8181 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON

8282 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

8483 context "Sum types" $ do

8584 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON

8685 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON

@@ -96,7 +95,6 @@ spec = do

9695 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]

9796 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

9897 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]

10098 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

10199 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []

102100 describe "Inlining Schemas" $ do

@@ -105,10 +103,547 @@ spec = do

105103 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

106104 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

107105 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

108− context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

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

112106

113107main :: IO ()

114108main = 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+28−114

@@ -10,9 +10,9 @@ import Prelude.Compat

1010import Control.Lens

1111

1212import Data.Aeson

13−import Data.Aeson.QQ.Simple

13+import Data.Aeson.QQ

1414import Data.HashMap.Strict (HashMap)

15−import qualified Data.HashSet.InsOrd as InsOrdHS

15+import qualified Data.Set as Set

1616import Data.Text (Text)

1717

1818import Data.Swagger

@@ -37,14 +37,11 @@ spec = do

3737 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON

3838 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON

3939 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON

40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON

4140 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

4241 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

4342 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

4443 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

4544 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

4845 describe "Swagger Object" $ do

4946 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

5047 context "PetStore Example" $

@@ -128,7 +125,7 @@ licenseExampleJSON = [aesonQQ|

128125

129126operationExample :: Operation

130127operationExample = mempty

131− & tags .~ InsOrdHS.fromList ["pet"]

128+ & tags .~ Set.fromList ["pet"]

132129 & summary ?~ "Updates a pet in the store with form data"

133130 & description ?~ ""

134131 & operationId ?~ "updatePetWithForm"

@@ -159,7 +156,7 @@ operationExample = mempty

159156 stringSchema :: ParamLocation -> ParamOtherSchema

160157 stringSchema loc = mempty

161158 & in_ .~ loc

162− & type_ ?~ SwaggerString

159+ & type_ .~ SwaggerString

163160

164161operationExampleJSON :: Value

165162operationExampleJSON = [aesonQQ|

@@ -225,7 +222,7 @@ operationExampleJSON = [aesonQQ|

225222

226223schemaPrimitiveExample :: Schema

227224schemaPrimitiveExample = mempty

228− & type_ ?~ SwaggerString

225+ & type_ .~ SwaggerString

229226 & format ?~ "email"

230227

231228schemaPrimitiveExampleJSON :: Value

@@ -238,14 +235,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

238235

239236schemaSimpleModelExample :: Schema

240237schemaSimpleModelExample = mempty

241− & type_ ?~ SwaggerObject

238+ & type_ .~ SwaggerObject

242239 & required .~ [ "name" ]

243240 & properties .~

244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))

241+ [ ("name", Inline (mempty & type_ .~ SwaggerString))

245242 , ("address", Ref (Reference "Address"))

246243 , ("age", Inline $ mempty

247244 & minimum_ ?~ 0

248− & type_ ?~ SwaggerInteger

245+ & type_ .~ SwaggerInteger

249246 & format ?~ "int32" ) ]

250247

251248schemaSimpleModelExampleJSON :: Value

@@ -273,8 +270,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

273270

274271schemaModelDictExample :: Schema

275272schemaModelDictExample = mempty

276− & type_ ?~ SwaggerObject

277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

273+ & type_ .~ SwaggerObject

274+ & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)

278275

279276schemaModelDictExampleJSON :: Value

280277schemaModelDictExampleJSON = [aesonQQ|

@@ -286,28 +283,15 @@ schemaModelDictExampleJSON = [aesonQQ|

286283}

287284|]

288285

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−

302286schemaWithExampleExample :: Schema

303287schemaWithExampleExample = mempty

304− & type_ ?~ SwaggerObject

288+ & type_ .~ SwaggerObject

305289 & properties .~

306290 [ ("id", Inline $ mempty

307− & type_ ?~ SwaggerInteger

291+ & type_ .~ SwaggerInteger

308292 & format ?~ "int64" )

309293 , ("name", Inline $ mempty

310− & type_ ?~ SwaggerString) ]

294+ & type_ .~ SwaggerString) ]

311295 & required .~ [ "name" ]

312296 & example ?~ [aesonQQ|

313297 {

@@ -346,19 +330,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

346330definitionsExample :: HashMap Text Schema

347331definitionsExample =

348332 [ ("Category", mempty

349− & type_ ?~ SwaggerObject

333+ & type_ .~ SwaggerObject

350334 & properties .~

351335 [ ("id", Inline $ mempty

352− & type_ ?~ SwaggerInteger

336+ & type_ .~ SwaggerInteger

353337 & format ?~ "int64")

354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

338+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

355339 , ("Tag", mempty

356− & type_ ?~ SwaggerObject

340+ & type_ .~ SwaggerObject

357341 & properties .~

358342 [ ("id", Inline $ mempty

359− & type_ ?~ SwaggerInteger

343+ & type_ .~ SwaggerInteger

360344 & format ?~ "int64")

361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

345+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

362346

363347definitionsExampleJSON :: Value

364348definitionsExampleJSON = [aesonQQ|

@@ -402,7 +386,7 @@ paramsDefinitionExample =

402386 & required ?~ True

403387 & schema .~ ParamOther (mempty

404388 & in_ .~ ParamQuery

405− & type_ ?~ SwaggerInteger

389+ & type_ .~ SwaggerInteger

406390 & format ?~ "int32" ))

407391 , ("limitParam", mempty

408392 & name .~ "limit"

@@ -410,7 +394,7 @@ paramsDefinitionExample =

410394 & required ?~ True

411395 & schema .~ ParamOther (mempty

412396 & in_ .~ ParamQuery

413− & type_ ?~ SwaggerInteger

397+ & type_ .~ SwaggerInteger

414398 & format ?~ "int32" )) ]

415399

416400paramsDefinitionExampleJSON :: Value

@@ -460,8 +444,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

460444-- Responses Definition object

461445-- =======================================================================

462446

463−securityDefinitionsExample :: SecurityDefinitions

464−securityDefinitionsExample = SecurityDefinitions

447+securityDefinitionsExample :: HashMap Text SecurityScheme

448+securityDefinitionsExample =

465449 [ ("api_key", SecurityScheme

466450 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

467451 , _securitySchemeDescription = Nothing })

@@ -493,46 +477,6 @@ securityDefinitionsExampleJSON = [aesonQQ|

493477}

494478|]

495479

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−

536480-- =======================================================================

537481-- Swagger object

538482-- =======================================================================

@@ -551,7 +495,7 @@ swaggerExample = mempty

551495 & at 200 ?~ Inline (mempty

552496 & description .~ "OK"

553497 & schema ?~ Inline (mempty

554− & type_ ?~ SwaggerObject

498+ & type_ .~ SwaggerObject

555499 & example ?~ [aesonQQ|

556500 {

557501 "created": 100,

@@ -560,9 +504,9 @@ swaggerExample = mempty

560504 & description ?~ "This is some real Todo right here"

561505 & properties .~

562506 [ ("created", Inline $ mempty

563− & type_ ?~ SwaggerInteger

507+ & type_ .~ SwaggerInteger

564508 & format ?~ "int32")

565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))

509+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))

566510 & produces ?~ MimeList [ "application/json" ]

567511 & parameters .~

568512 [ Inline $ mempty

@@ -571,8 +515,8 @@ swaggerExample = mempty

571515 & description ?~ "TodoId param"

572516 & schema .~ ParamOther (mempty

573517 & in_ .~ ParamPath

574− & type_ ?~ SwaggerString ) ]

575− & tags .~ InsOrdHS.fromList [ "todo" ] ))

518+ & type_ .~ SwaggerString ) ]

519+ & tags .~ Set.fromList [ "todo" ] ))

576520

577521swaggerExampleJSON :: Value

578522swaggerExampleJSON = [aesonQQ|

@@ -1670,33 +1614,3 @@ petstoreExampleJSON = [aesonQQ|

16701614 }

16711615}

16721616|]

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.hsnew file+8

@@ -0,0 +1,8 @@

1+module Main (main) where

3+import System.FilePath.Glob (glob)

4+import Test.DocTest (doctest)

6+main :: IO ()

7+main = glob "src/**/*.hs" >>= doctest'

8+ where doctest' files = doctest $ "-Iinclude/" : "-D__DOCTEST__" : files

test/doctests.hsdeleted−12

@@ -1,12 +0,0 @@

1−module Main where

2−

3−import Build_doctests (flags, pkgs, module_sources)

4−import Data.Foldable (traverse_)

5−import Test.DocTest

6−

7−main :: IO ()

8−main = do

9− traverse_ putStrLn args

10− doctest args

11− where

12− args = flags ++ pkgs ++ module_sources