master..cbf93da · typeable/swagger2

git.iko.soy/typeable/swagger2

39 files changed+1783−5179

unifiedsplit

.ghci−2 .gitignore−2 .travis.yml+67−150 CHANGELOG.md+1−186 LICENSE+1−1 README.md+1−3 Setup.hs−31 cabal.project−2 examples/hackage.hs+24−40 hackage-docs.sh−78 src/Data/Swagger.hs+13−104 src/Data/Swagger/Declare.hs+5−83 src/Data/Swagger/Internal.hs+143−399 src/Data/Swagger/Internal/AesonUtils.hs−346 src/Data/Swagger/Internal/ParamSchema.hs+23−120 src/Data/Swagger/Internal/Schema.hs+81−386 src/Data/Swagger/Internal/Schema/Validation.hs−511 src/Data/Swagger/Internal/TypeShape.hs−66 src/Data/Swagger/Internal/Utils.hs+46−9 src/Data/Swagger/Lens.hs+9−30 src/Data/Swagger/Operation.hs−193 src/Data/Swagger/Optics.hs−597 src/Data/Swagger/ParamSchema.hs+2−5 src/Data/Swagger/Schema.hs+2−24 src/Data/Swagger/Schema/Generator.hs−114 src/Data/Swagger/Schema/Validation.hs+308−74 src/Data/Swagger/SchemaOptions.hs−35 stack-lts-2.yaml+5 stack.yaml+3−7 swagger2.cabal+42−103 test/Data/Swagger/CommonTestTypes.hs−679 test/Data/Swagger/ParamSchemaSpec.hs+84−10 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs+70−151 test/Data/Swagger/SchemaSpec.hs+513−25 test/Data/SwaggerSpec.hs+330−426 test/DocTest.hs+8 test/SpecCommon.hs+2−7 test/doctests.hs−12

.ghcideleted−2

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

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

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

.gitignore−2

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

11dist

2−dist-newstyle

3−.ghc.environment.*

42cabal-dev

53*.o

64*.hi

.travis.yml+67−150

@@ -1,162 +1,79 @@

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+

4223before_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

24+ - unset CC

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

26+

7427install:

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

28+ - cabal --version

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

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

31+ then

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

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

34+ fi

35+ - travis_retry cabal update -v

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

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

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

39+

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

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

42+ then

43+ echo "cabal build-cache HIT";

44+ rm -rfv .ghc;

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

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

47+ else

48+ echo "cabal build-cache MISS";

49+ rm -rf $HOME/.cabsnap;

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

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

52+ fi

53+

54+# snapshot package-db on cache miss

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

56+ then

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

58+ mkdir $HOME/.cabsnap;

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

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

61+ fi

62+

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

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

12665script:

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

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

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

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

69+ - cabal test

70+ - cabal check

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

72+

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

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

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

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

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

16078

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

16279# EOF

CHANGELOG.md+1−186

@@ -1,192 +1,7 @@

1−2.5

2−---

3−

4−Highlights:

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

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

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

8−

9−Fixes and minor changes:

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

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

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

13−

14−2.4

15−---

16−

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

18−- Tags aren't sorted

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

20−- Schema type is optional

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

22−- Take concrete 'Proxy' as argument

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

24−- GHC-8.8 preparations

25−

26−2.3.1.1

27−-------

28−

29−- Allow `network-3.0`

30−

31−2.3.1

32−-----

33−

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

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

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

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

38−- Make nullary schemas valid

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

40−

41−2.3.0.1

42−-------

43−

44−- Support GHC-8.6

45−

46−2.3

47−---

48−

49−Major changes:

50−

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

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

53−

54−Dependencies and CI:

55−

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

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

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

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

60−

61−2.2.2

62−-----

63−

64−* Add `ToSchema Version` instance

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

66−* PVP bounds

67−

68−2.2.1

69−-----

70−

71−* Add `Semigroup` instances

72−* GHC-8.4 compatibility

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

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

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

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

77−

78−2.2

79−---

80−

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

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

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

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

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

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

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

88−

89−2.1.6

90−-----

91−

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

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

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

95−

96−2.1.5

97−-----

98−

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

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

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

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

103−

104−2.1.4.1

105−-------

106−

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

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

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

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

111−

112−2.1.4

113−-----

114−

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

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

117−

118−2.1.3

119−-----

120−

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

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

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

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

125−

126−2.1.2.1

127−-------

128−

129−* Bug fix previous release

130−

131−2.1.2

132−---

133−

134−* Minor changes:

135− * Support `aeson-1.0.0.0` (see [#70](https://github.com/GetShopTV/swagger2/pull/70)).

136−

137−2.1.1

138−---

139−

140−* Minor changes:

141− * Proper `Schema` examples for `Char`, `Day`, `LocalTime`, `ZonedTime` and `UTCTime`.

142−

143−2.1

144−---

145−

146−* Major changes:

147− * Use `InsOrdHashMap` to preserve insertion order for endpoints and definitions (see [#56](https://github.com/GetShopTV/swagger2/pull/56));

148− * Add support for GHC 8.0 (see [#65](https://github.com/GetShopTV/swagger2/pull/65)).

149−

150−2.0.2

151−---

152−

153−* Fixes:

154− * Fix `additionalProperties` to allow references;

155− * Fix `ToSchema` instances for `Map` and `HashMap` (prevent infinite recursion for recursive values).

156−

157−2.0.1

158−---

159−

160−* Fixes:

161− * Re-export `Pattern` synonym from `Data.Swagger`;

162− * Documentation fixes.

163−

164−2.0

165−---

166−

167−* Major changes:

168− * GHC 7.8 support (see [#49](https://github.com/GetShopTV/swagger2/pull/49));

169− * Switch to classy field lenses (see [#41](https://github.com/GetShopTV/swagger2/pull/41));

170− * Add `Data.Swagger.Schema.Validation` (see [#18](https://github.com/GetShopTV/swagger2/pull/18));

171− * Add `Data.Swagger.Operation` with helpers (see [#50](https://github.com/GetShopTV/swagger2/pull/50));

172− * Add `IsString` instances for some types (see [#47](https://github.com/GetShopTV/swagger2/pull/47));

173− * Add helpers to sketch `Schema` from JSON (see [#48](https://github.com/GetShopTV/swagger2/pull/48)).

174−

175−* Minor changes:

176− * Make `NamedSchema` a `data` rather than `type` (see [#42](https://github.com/GetShopTV/swagger2/pull/42));

177− * Change `Definitions` to `Definitions Schema`;

178− * Add schema templates for `"binary"`, `"byte"` and `"password"` formats (see [63ed597](https://github.com/GetShopTV/swagger2/commit/63ed59736dc4f942f0e2a7d668d7cee513fa9eaf));

179− * Add `Monoid` instance for `Contact`;

180− * Change `tags` to be `Set` rather than list.

181−

182−* Fixes:

183− * Fix schema for `()` and nullary constructors (see [ab65c4a](https://github.com/GetShopTV/swagger2/commit/ab65c4a48253c34f8a88221a53dc97bf5e6e8d29));

184− * Fix `Operation` `FromJSON` instance to allow missing `tags` and `parameters` properties.

185−

18611.2.1

1872---

1883

189−* Minor changes:

4+* Minor change:

1905 * Change `_SwaggerItemsPrimitive` type from a `Prism'` to a more restrictive `Review`-like `Optic'`.

1916

1927* Fixes:

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+24−40

@@ -13,28 +13,13 @@ import GHC.Generics

1313import Data.Swagger

1414import Data.Swagger.Declare

1515import Data.Swagger.Lens

16−import Data.Swagger.Operation

1716

1817type Username = Text

1918

2019data UserSummary = UserSummary

2120 { summaryUsername :: Username

2221 , 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−

22+ } deriving (Generic, ToSchema)

3823

3924type Group = Text

4025

@@ -52,33 +37,32 @@ hackageSwagger = spec & definitions .~ defs

5237 where

5338 (defs, spec) = runDeclare declareHackageSwagger mempty

5439

55−declareHackageSwagger :: Declare (Definitions Schema) Swagger

40+declareHackageSwagger :: Declare Definitions Swagger

5641declareHackageSwagger = do

57− -- param schemas

5842 let usernameParamSchema = toParamSchema (Proxy :: Proxy Username)

59−

60− -- responses

61− userSummaryResponse <- declareResponse (Proxy :: Proxy UserSummary)

62− userDetailedResponse <- declareResponse (Proxy :: Proxy UserDetailed)

63− packagesResponse <- declareResponse (Proxy :: Proxy [Package])

64−

43+ userSummarySchemaRef <- declareSchemaRef (Proxy :: Proxy UserSummary)

44+ userDetailedSchemaRef <- declareSchemaRef (Proxy :: Proxy UserDetailed)

45+ packagesSchemaRef <- declareSchemaRef (Proxy :: Proxy [Package])

6546 return $ mempty

66− & paths .~

67− [ ("/users", mempty & get ?~ (mempty

68− & produces ?~ MimeList ["application/json"]

69− & at 200 ?~ Inline userSummaryResponse))

70− , ("/user/{username}", mempty & get ?~ (mempty

71− & produces ?~ MimeList ["application/json"]

72− & parameters .~ [ Inline $ mempty

73− & name .~ "username"

74− & required ?~ True

75− & schema .~ ParamOther (mempty

76− & in_ .~ ParamPath

77− & paramSchema .~ usernameParamSchema) ]

78− & at 200 ?~ Inline userDetailedResponse))

79− , ("/packages", mempty & get ?~ (mempty

80− & produces ?~ MimeList ["application/json"]

81− & at 200 ?~ Inline packagesResponse))

47+ & paths.pathsMap .~

48+ [ ("/users", mempty & pathItemGet ?~ (mempty

49+ & operationProduces ?~ MimeList ["application/json"]

50+ & operationResponses .~ (mempty

51+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userSummarySchemaRef))))

52+ , ("/user/{username}", mempty & pathItemGet ?~ (mempty

53+ & operationProduces ?~ MimeList ["application/json"]

54+ & operationParameters .~ [ Inline $ mempty

55+ & paramName .~ "username"

56+ & paramRequired ?~ True

57+ & paramSchema .~ ParamOther (mempty

58+ & paramOtherSchemaIn .~ ParamPath

59+ & paramOtherSchemaParamSchema .~ usernameParamSchema) ]

60+ & operationResponses .~ (mempty

61+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ userDetailedSchemaRef))))

62+ , ("/packages", mempty & pathItemGet ?~ (mempty

63+ & operationProduces ?~ MimeList ["application/json"]

64+ & operationResponses .~ (mempty

65+ & responsesResponses . at 200 ?~ Inline (mempty & responseSchema ?~ packagesSchemaRef))))

8266 ]

8367

8468main :: IO ()

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+13−104

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

1−{-# LANGUAGE CPP #-}

21-- |

3−-- Module: Data.Swagger

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

5−-- Stability: experimental

6−--

72-- Swagger™ is a project used to describe and document RESTful APIs.

83--

94-- The Swagger specification defines a set of files required to describe such an API.

@@ -23,19 +18,10 @@ module Data.Swagger (

2318 -- ** Schema specification

2419 -- $schema

2520

26− -- ** Manipulation

27− -- $manipulation

28−

29− -- ** Validation

30− -- $validation

31−

3221 -- * Re-exports

3322 module Data.Swagger.Lens,

34− module Data.Swagger.Optics,

35− module Data.Swagger.Operation,

3623 module Data.Swagger.ParamSchema,

3724 module Data.Swagger.Schema,

38− module Data.Swagger.Schema.Validation,

3925

4026 -- * Swagger specification

4127 Swagger(..),

@@ -77,8 +63,6 @@ module Data.Swagger (

7763 NamedSchema(..),

7864 SwaggerItems(..),

7965 Xml(..),

80− Pattern,

81− AdditionalProperties(..),

8266

8367 -- ** Responses

8468 Responses(..),

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

8973 SecurityScheme(..),

9074 SecuritySchemeType(..),

9175 SecurityRequirement(..),

92− SecurityDefinitions(..),

9376

9477 -- *** API key

9578 ApiKeyParams(..),

@@ -114,11 +97,8 @@ module Data.Swagger (

11497) where

11598

11699import Data.Swagger.Lens

117−import Data.Swagger.Optics ()

118−import Data.Swagger.Operation

119100import Data.Swagger.ParamSchema

120101import Data.Swagger.Schema

121−import Data.Swagger.Schema.Validation

122102

123103import Data.Swagger.Internal

124104

@@ -178,47 +158,43 @@ import Data.Swagger.Internal

178158

179159-- $lens

180160--

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

182−--

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

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

162+-- to work comfortly with it. In combination with @'Monoid'@ instances, lenses

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

186164--

187165-- >>> :{

188166-- encode $ (mempty :: Swagger)

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

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

190168-- & paths .~

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

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

193−-- & at 200 ?~ ("OK" & _Inline.schema ?~ Ref (Reference "User"))

194−-- & at 404 ?~ "User info not found")) ]

171+-- & at 200 ?~ Inline (mempty & schema ?~ Ref (Reference "User")))) ]

195172-- :}

196−-- "{\"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\"}}}"

173+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}"

197174--

198−-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@

199−-- which produces @application/json@ output. It should respond with code @200@ and body specified

175+-- In the snippet above we declare API with a single path @/user@ providing method @GET@

176+-- which produces @application/json@ output and should respond with code @200@ and body specified

200177-- by schema @User@ which is defined in @'definitions'@ property of swagger specification.

201−-- Alternatively it may respond with code @404@ meaning that user info is not found.

202178--

203179-- For convenience, @swagger2@ uses /classy field lenses/. It means that

204180-- field accessor names can be overloaded for different types. One such

205−-- common field is @'description'@. Many components of a Swagger specification

181+-- common field is @'description'@. Many components of Swagger specification

206182-- can have descriptions, and you can use the same name for them:

207183--

208184-- >>> encode $ (mempty :: Response) & description .~ "No content"

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

210186-- >>> :{

211187-- encode $ (mempty :: Schema)

212−-- & type_ ?~ SwaggerBoolean

188+-- & type_ .~ SwaggerBoolean

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

214190-- :}

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

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

216192--

217193-- @'ParamSchema'@ is basically the /base schema specification/ and many types contain it (see @'HasParamSchema'@).

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

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

220196--

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

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

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

223199--

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

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

226202--

227203-- >>> :{

228204-- encode $ (mempty :: Operation)

229−-- & at 404 ?~ "Not found"

205+-- & at 404 ?~ Inline (mempty & description .~ "Not found")

230206-- :}

231207-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"

232208--

@@ -236,7 +212,7 @@ import Data.Swagger.Internal

236212-- A few other field accessors are modified in this way:

237213--

238214-- - @'in_'@, @'type_'@, @'default_'@ (as keywords);

239−-- - @'maximum_'@, @'minimum_'@, @'head_'@ (as conflicting with @Prelude@);

215+-- - @'maximum_'@ and @'minimum_'@ (as conflicting with @Prelude@);

240216-- - @'enum_'@ (as conflicting with @Control.Lens@).

241217

242218-- $schema

@@ -278,73 +254,6 @@ import Data.Swagger.Internal

278254-- >>> encode (Person "David" 28)

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

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

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

282−--

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

284−-- schema for basic enums like

285−--

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

287−-- >>> instance ToSchema SampleEnum

288−-- >>> instance ToJSON SampleEnum

289−--

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

291−--

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

293−-- >>> instance ToSchema SampleSumType

294−-- >>> instance ToJSON SampleSumType

295−--

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

297−--

298−#if __GLASGOW_HASKELL__ < 800

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

300−-- >>> instance ToSchema BadMixedType

301−-- ...

302−-- ... error:

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

304−-- ... BadMixedType)

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

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

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

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

309−-- ... declareNamedSchema

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

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

312−#else

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

314−-- >>> instance ToSchema BadMixedType

315−-- ...

316−-- ... error:

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

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

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

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

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

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

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

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

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

326−-- ... declareNamedSchema

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

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

329−#endif

330−--

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

332−--

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

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

335−-- >>> instance ToJSON BadMixedType

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

336258--

337259

338−-- $manipulation

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

340−-- For instance, <servant-swagger http://hackage.haskell.org/package/servant-swagger> generates basic @'Swagger'@

341−-- for a type-level servant API.

342−--

343−-- Lenses and prisms can be used to manipulate such specification to add additional information, tags, extra responses, etc.

344−-- To facilitate common needs, @"Data.Swagger.Operation"@ module provides useful helpers.

345−

346−-- $validation

347−-- While @'ToParamSchema'@ and @'ToSchema'@ provide means to easily obtain schemas for Haskell types,

348−-- there is no static mechanism to ensure those instances correspond to the @'ToHttpApiData'@ or @'ToJSON'@ instances.

349−--

350−-- @"Data.Swagger.Schema.Validation"@ addresses @'ToJSON'@/@'ToSchema'@ validation.

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

@@ -2,33 +2,15 @@

22{-# LANGUAGE FlexibleInstances #-}

33{-# LANGUAGE FunctionalDependencies #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE UndecidableInstances #-}

6−-- |

7−-- Module: Data.Swagger.Declare

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

9−-- Stability: experimental

10−--

11−-- Declare monad transformer and associated functions.

125module Data.Swagger.Declare where

136

147import Prelude ()

158import Prelude.Compat

169

1710import Control.Monad

18−import Control.Monad.Cont (ContT)

19−import Control.Monad.List (ListT)

20−import Control.Monad.Reader (ReaderT)

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

3112import Data.Functor.Identity

13+import Data.Monoid

3214

3315-- | A declare monad transformer parametrized by:

3416--

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

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

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

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

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

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

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

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

5436

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

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

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

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

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

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

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

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

6143

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

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

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

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

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

9173

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−

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

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

10176looks f = f <$> look

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

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

145120undeclare = runIdentity . undeclareT

146121

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+143−399

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE DeriveDataTypeable #-}

4−{-# LANGUAGE DeriveFunctor #-}

53{-# LANGUAGE DeriveGeneric #-}

64{-# LANGUAGE DeriveTraversable #-}

75{-# LANGUAGE FlexibleContexts #-}

@@ -12,66 +10,36 @@

1210{-# LANGUAGE RecordWildCards #-}

1311{-# LANGUAGE ScopedTypeVariables #-}

1412{-# LANGUAGE StandaloneDeriving #-}

15−{-# LANGUAGE TemplateHaskell #-}

16−{-# LANGUAGE TypeFamilies #-}

1713{-# LANGUAGE UndecidableInstances #-}

18−#if __GLASGOW_HASKELL__ <710

19−{-# LANGUAGE PolyKinds #-}

20−#endif

2114#include "overlapping-compat.h"

2215module Data.Swagger.Internal where

2316

2417import Prelude ()

2518import Prelude.Compat

2619

27−import Control.Lens ((&), (.~), (?~))

2820import Control.Applicative

21+import Control.Monad

2922import Data.Aeson

3023import qualified Data.Aeson.Types as JSON

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

32−import Data.Hashable (Hashable)

25+import Data.HashMap.Strict (HashMap)

3326import qualified Data.HashMap.Strict as HashMap

34−import Data.HashSet.InsOrd (InsOrdHashSet)

3527import Data.Map (Map)

3628import qualified Data.Map as Map

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

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

29+import Data.Monoid

3930import Data.Scientific (Scientific)

40−import Data.String (IsString(..))

31+import Data.String (fromString)

4132import Data.Text (Text)

4233import qualified Data.Text as Text

4334import GHC.Generics (Generic)

44−import Network.Socket (HostName, PortNumber)

35+import Network (HostName, PortNumber)

4536import Network.HTTP.Media (MediaType)

4637import Text.Read (readMaybe)

4738

48−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

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

50−

51−import Generics.SOP.TH (deriveGeneric)

52−import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON

53− ,sopSwaggerGenericToJSONWithOpts

54− ,sopSwaggerGenericParseJSON

55− ,HasSwaggerAesonOptions(..)

56− ,AesonDefaultValue(..)

57− ,mkSwaggerAesonOptions

58− ,saoAdditionalPairs

59− ,saoSubObject)

6039import Data.Swagger.Internal.Utils

6140

62−#if MIN_VERSION_aeson(0,10,0)

63−import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToEncoding)

64−#define DEFINE_TOENCODING toEncoding = sopSwaggerGenericToEncoding

65−#else

66−#define DEFINE_TOENCODING

67−#endif

68−

69−-- $setup

70−-- >>> :seti -XDataKinds

71−-- >>> import Data.Aeson

72−

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

74−type Definitions = InsOrdHashMap Text

42+type Definitions = HashMap Text

7543

7644-- | This is the root document object for the API specification.

7745data Swagger = Swagger

@@ -103,7 +71,7 @@ data Swagger = Swagger

10371 -- | The available paths and operations for the API.

10472 -- Holds the relative paths to the individual endpoints.

10573 -- The path is appended to the @'basePath'@ in order to construct the full URL.

106− , _swaggerPaths :: InsOrdHashMap FilePath PathItem

74+ , _swaggerPaths :: HashMap FilePath PathItem

10775

10876 -- | An object to hold data types produced and consumed by operations.

10977 , _swaggerDefinitions :: Definitions Schema

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

11785 , _swaggerResponses :: Definitions Response

11886

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

120− , _swaggerSecurityDefinitions :: SecurityDefinitions

88+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme

12189

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

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

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

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

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

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

133− , _swaggerTags :: InsOrdHashSet Tag

101+ , _swaggerTags :: [Tag]

134102

135103 -- | Additional external documentation.

136104 , _swaggerExternalDocs :: Maybe ExternalDocs

@@ -182,18 +150,12 @@ data License = License

182150 , _licenseUrl :: Maybe URL

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

184152

185−instance IsString License where

186− fromString s = License (fromString s) Nothing

187−

188153-- | The host (name or ip) serving the API. It MAY include a port.

189154data Host = Host

190155 { _hostName :: HostName -- ^ Host name.

191156 , _hostPort :: Maybe PortNumber -- ^ Optional port.

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

193158

194−instance IsString Host where

195− fromString s = Host s Nothing

196−

197159hostConstr :: Constr

198160hostConstr = mkConstr hostDataType "Host" [] Prefix

199161

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

252214data Operation = Operation

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

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

255− _operationTags :: InsOrdHashSet TagName

217+ _operationTags :: [TagName]

256218

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

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

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

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

310272

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

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

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

313275

314276mimeListConstr :: Constr

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

@@ -360,8 +322,8 @@ data ParamOtherSchema = ParamOtherSchema

360322 -- Default value is @False@.

361323 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool

362324

363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema

364− } deriving (Eq, Show, Generic, Typeable, Data)

325+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema

326+ } deriving (Eq, Show, Generic, Data, Typeable)

365327

366328-- | Items for @'SwaggerArray'@ schemas.

367329--

@@ -374,9 +336,9 @@ data ParamOtherSchema = ParamOtherSchema

374336--

375337-- @'SwaggerItemsArray'@ should be used to specify tuple @'Schema'@s.

376338data SwaggerItems t where

377− SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k

378− SwaggerItemsObject :: Referenced Schema -> SwaggerItems 'SwaggerKindSchema

379− SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems 'SwaggerKindSchema

339+ SwaggerItemsPrimitive :: Maybe (CollectionFormat t) -> ParamSchema t -> SwaggerItems t

340+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema

341+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems Schema

380342 deriving (Typeable)

381343

382344deriving instance Eq (SwaggerItems t)

@@ -386,66 +348,17 @@ deriving instance Show (SwaggerItems t)

386348swaggerItemsPrimitiveConstr :: Constr

387349swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix

388350

389−swaggerItemsObjectConstr :: Constr

390−swaggerItemsObjectConstr = mkConstr swaggerItemsDataType "SwaggerItemsObject" [] Prefix

391−

392−swaggerItemsArrayConstr :: Constr

393−swaggerItemsArrayConstr = mkConstr swaggerItemsDataType "SwaggerItemsArray" [] Prefix

394−

395351swaggerItemsDataType :: DataType

396352swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimitiveConstr]

397353

398−-- Note: unfortunately we have to write these Data instances by hand,

399−-- to get better contexts / avoid duplicate name when using standalone deriving

400−

401−instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where

402− -- TODO: define gfoldl

354+instance OVERLAPPABLE_ Data t => Data (SwaggerItems t) where

403355 gunfold k z c = case constrIndex c of

404356 1 -> k (k (z SwaggerItemsPrimitive))

405357 _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems t)."

406358 toConstr _ = swaggerItemsPrimitiveConstr

407359 dataTypeOf _ = swaggerItemsDataType

408360

409−-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only

410−instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where

411− -- TODO: define gfoldl

412− gunfold k z c = case constrIndex c of

413− 1 -> k (k (z SwaggerItemsPrimitive))

414− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindParamOtherSchema)."

415− toConstr _ = swaggerItemsPrimitiveConstr

416− dataTypeOf _ = swaggerItemsDataType

417−

418−instance Data (SwaggerItems 'SwaggerKindSchema) where

419− gfoldl _ _ (SwaggerItemsPrimitive _ _) = error $ " Data.Data.gfoldl: Constructor SwaggerItemsPrimitive used to construct SwaggerItems SwaggerKindSchema"

420− gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref

421− gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref

422−

423− gunfold k z c = case constrIndex c of

424− 2 -> k (z SwaggerItemsObject)

425− 3 -> k (z SwaggerItemsArray)

426− _ -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type (SwaggerItems SwaggerKindSchema)."

427−

428− toConstr (SwaggerItemsPrimitive _ _) = error "Not supported"

429− toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr

430− toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr

431−

432− dataTypeOf _ = swaggerItemsDataType

433−

434−-- | Type used as a kind to avoid overlapping instances.

435−data SwaggerKind t

436− = SwaggerKindNormal t

437− | SwaggerKindParamOtherSchema

438− | SwaggerKindSchema

439− deriving (Typeable)

440−

441−deriving instance Typeable 'SwaggerKindNormal

442−deriving instance Typeable 'SwaggerKindParamOtherSchema

443−deriving instance Typeable 'SwaggerKindSchema

444−

445−type family SwaggerKindType (k :: SwaggerKind *) :: *

446−type instance SwaggerKindType ('SwaggerKindNormal t) = t

447−type instance SwaggerKindType 'SwaggerKindSchema = Schema

448−type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema

361+deriving instance Data (SwaggerItems Schema)

449362

450363data SwaggerType t where

451364 SwaggerString :: SwaggerType t

@@ -453,9 +366,9 @@ data SwaggerType t where

453366 SwaggerInteger :: SwaggerType t

454367 SwaggerBoolean :: SwaggerType t

455368 SwaggerArray :: SwaggerType t

456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema

457− SwaggerNull :: SwaggerType 'SwaggerKindSchema

458− SwaggerObject :: SwaggerType 'SwaggerKindSchema

369+ SwaggerFile :: SwaggerType ParamOtherSchema

370+ SwaggerNull :: SwaggerType Schema

371+ SwaggerObject :: SwaggerType Schema

459372 deriving (Typeable)

460373

461374deriving instance Eq (SwaggerType t)

@@ -464,33 +377,33 @@ deriving instance Show (SwaggerType t)

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

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

466379

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

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

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

469382

470−swaggerCommonTypes :: [SwaggerType k]

383+swaggerCommonTypes :: [SwaggerType t]

471384swaggerCommonTypes = [SwaggerString, SwaggerNumber, SwaggerInteger, SwaggerBoolean, SwaggerArray]

472385

473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]

386+swaggerParamTypes :: [SwaggerType ParamOtherSchema]

474387swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]

475388

476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]

389+swaggerSchemaTypes :: [SwaggerType Schema]

477390swaggerSchemaTypes = swaggerCommonTypes ++ [error "SwaggerFile is invalid SwaggerType Schema", SwaggerNull, SwaggerObject]

478391

479392swaggerTypeConstrs :: [Constr]

480−swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType 'SwaggerKindSchema])

393+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType Schema])

481394 ++ [swaggerTypeConstr SwaggerFile, swaggerTypeConstr SwaggerNull, swaggerTypeConstr SwaggerObject]

482395

483−instance Typeable t => Data (SwaggerType ('SwaggerKindNormal t)) where

396+instance OVERLAPPABLE_ Typeable t => Data (SwaggerType t) where

484397 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes

485398 toConstr = swaggerTypeConstr

486399 dataTypeOf = swaggerTypeDataType

487400

488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where

401+instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where

489402 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes

490403 toConstr = swaggerTypeConstr

491404 dataTypeOf = swaggerTypeDataType

492405

493−instance Data (SwaggerType 'SwaggerKindSchema) where

406+instance OVERLAPPABLE_ Data (SwaggerType Schema) where

494407 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes

495408 toConstr = swaggerTypeConstr

496409 dataTypeOf = swaggerTypeDataType

@@ -530,7 +443,7 @@ data CollectionFormat t where

530443 -- Corresponds to multiple parameter instances

531444 -- instead of multiple values for a single instance @foo=bar&foo=baz@.

532445 -- This is valid only for parameters in @'ParamQuery'@ or @'ParamFormData'@.

533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema

446+ CollectionMulti :: CollectionFormat ParamOtherSchema

534447 deriving (Typeable)

535448

536449deriving instance Eq (CollectionFormat t)

@@ -546,12 +459,12 @@ collectionFormatDataType = mkDataType "Data.Swagger.CollectionFormat" $

546459collectionCommonFormats :: [CollectionFormat t]

547460collectionCommonFormats = [ CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes ]

548461

549−instance Data t => Data (CollectionFormat ('SwaggerKindNormal t)) where

462+instance OVERLAPPABLE_ Data t => Data (CollectionFormat t) where

550463 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats

551464 toConstr = collectionFormatConstr

552465 dataTypeOf _ = collectionFormatDataType

553466

554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)

467+deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)

555468

556469type ParamName = Text

557470

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

560473 , _schemaDescription :: Maybe Text

561474 , _schemaRequired :: [ParamName]

562475

563− , _schemaAllOf :: Maybe [Referenced Schema]

564− , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

565− , _schemaAdditionalProperties :: Maybe AdditionalProperties

476+ , _schemaAllOf :: Maybe [Schema]

477+ , _schemaProperties :: HashMap Text (Referenced Schema)

478+ , _schemaAdditionalProperties :: Maybe Schema

566479

567480 , _schemaDiscriminator :: Maybe Text

568481 , _schemaReadOnly :: Maybe Bool

@@ -573,7 +486,7 @@ data Schema = Schema

573486 , _schemaMaxProperties :: Maybe Integer

574487 , _schemaMinProperties :: Maybe Integer

575488

576− , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema

489+ , _schemaParamSchema :: ParamSchema Schema

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

578491

579492-- | A @'Schema'@ with an optional name.

@@ -586,7 +499,7 @@ data NamedSchema = NamedSchema

586499-- | Regex pattern for @string@ type.

587500type Pattern = Text

588501

589−data ParamSchema (t :: SwaggerKind *) = ParamSchema

502+data ParamSchema t = ParamSchema

590503 { -- | Declares the value of the parameter that the server will use if none is provided,

591504 -- for example a @"count"@ to control the number of results per page might default to @100@

592505 -- if not supplied by the client in the request.

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

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

595508 _paramSchemaDefault :: Maybe Value

596509

597− , _paramSchemaType :: Maybe (SwaggerType t)

510+ , _paramSchemaType :: SwaggerType t

598511 , _paramSchemaFormat :: Maybe Format

599512 , _paramSchemaItems :: Maybe (SwaggerItems t)

600513 , _paramSchemaMaximum :: Maybe Scientific

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

611524 , _paramSchemaMultipleOf :: Maybe Scientific

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

613526

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

527+deriving instance (Data t, Data (SwaggerType t), Data (SwaggerItems t)) => Data (ParamSchema t)

615528

616529data Xml = Xml

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

@@ -653,7 +566,7 @@ data Responses = Responses

653566

654567 -- | Any HTTP status code can be used as the property name (one property per HTTP status code).

655568 -- Describes the expected response for those HTTP status codes.

656− , _responsesResponses :: InsOrdHashMap HttpStatusCode (Referenced Response)

569+ , _responsesResponses :: HashMap HttpStatusCode (Referenced Response)

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

658571

659572type HttpStatusCode = Int

@@ -672,22 +585,19 @@ data Response = Response

672585 , _responseSchema :: Maybe (Referenced Schema)

673586

674587 -- | A list of headers that are sent with the response.

675− , _responseHeaders :: InsOrdHashMap HeaderName Header

588+ , _responseHeaders :: HashMap HeaderName Header

676589

677590 -- | An example of the response message.

678591 , _responseExamples :: Maybe Example

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

680593

681−instance IsString Response where

682− fromString s = Response (fromString s) Nothing mempty Nothing

683−

684594type HeaderName = Text

685595

686596data Header = Header

687597 { -- | A short description of the header.

688598 _headerDescription :: Maybe Text

689599

690− , _headerParamSchema :: ParamSchema ('SwaggerKindNormal Header)

600+ , _headerParamSchema :: ParamSchema Header

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

692602

693603data Example = Example { getExample :: Map MediaType Value }

@@ -738,7 +648,7 @@ data OAuth2Params = OAuth2Params

738648 _oauth2Flow :: OAuth2Flow

739649

740650 -- | The available scopes for the OAuth2 security scheme.

741− , _oauth2Scopes :: InsOrdHashMap Text Text

651+ , _oauth2Scopes :: HashMap Text Text

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

743653

744654data SecuritySchemeType

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

755665 , _securitySchemeDescription :: Maybe Text

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

757667

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−

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

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

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

777671newtype SecurityRequirement = SecurityRequirement

778− { getSecurityRequirement :: InsOrdHashMap Text [Text]

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

672+ { getSecurityRequirement :: HashMap Text [Text]

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

780674

781675-- | Tag name.

782676type TagName = Text

@@ -793,12 +687,7 @@ data Tag = Tag

793687

794688 -- | Additional external documentation for this tag.

795689 , _tagExternalDocs :: Maybe ExternalDocs

796− } deriving (Eq, Ord, Show, Generic, Data, Typeable)

797−

798−instance Hashable Tag

799−

800−instance IsString Tag where

801− fromString s = Tag (fromString s) Nothing Nothing

690+ } deriving (Eq, Show, Generic, Data, Typeable)

802691

803692-- | Allows referencing an external resource for extended documentation.

804693data ExternalDocs = ExternalDocs

@@ -808,9 +697,7 @@ data ExternalDocs = ExternalDocs

808697

809698 -- | The URL for the target documentation.

810699 , _externalDocsUrl :: URL

811− } deriving (Eq, Ord, Show, Generic, Data, Typeable)

812−

813−instance Hashable ExternalDocs

700+ } deriving (Eq, Show, Generic, Data, Typeable)

814701

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

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

@@ -820,116 +707,69 @@ newtype Reference = Reference { getReference :: Text }

820707data Referenced a

821708 = Ref Reference

822709 | Inline a

823− deriving (Eq, Show, Functor, Data, Typeable)

824−

825−instance IsString a => IsString (Referenced a) where

826− fromString = Inline . fromString

827−

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)

833710 deriving (Eq, Show, Data, Typeable)

834711

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

713+

835714-- =======================================================================

836715-- Monoid instances

837716-- =======================================================================

838717

839−instance Semigroup Swagger where

840− (<>) = genericMappend

841718instance Monoid Swagger where

842719 mempty = genericMempty

843− mappend = (<>)

720+ mappend = genericMappend

844721

845−instance Semigroup Info where

846− (<>) = genericMappend

847722instance Monoid Info where

848723 mempty = genericMempty

849− mappend = (<>)

724+ mappend = genericMappend

850725

851−instance Semigroup Contact where

852− (<>) = genericMappend

853726instance Monoid Contact where

854727 mempty = genericMempty

855− mappend = (<>)

728+ mappend = genericMappend

856729

857−instance Semigroup PathItem where

858− (<>) = genericMappend

859730instance Monoid PathItem where

860731 mempty = genericMempty

861− mappend = (<>)

732+ mappend = genericMappend

862733

863−instance Semigroup Schema where

864− (<>) = genericMappend

865734instance Monoid Schema where

866735 mempty = genericMempty

867− mappend = (<>)

736+ mappend = genericMappend

868737

869−instance Semigroup (ParamSchema t) where

870− (<>) = genericMappend

871738instance Monoid (ParamSchema t) where

872739 mempty = genericMempty

873− mappend = (<>)

740+ mappend = genericMappend

874741

875−instance Semigroup Param where

876− (<>) = genericMappend

877742instance Monoid Param where

878743 mempty = genericMempty

879− mappend = (<>)

744+ mappend = genericMappend

880745

881−instance Semigroup ParamOtherSchema where

882− (<>) = genericMappend

883746instance Monoid ParamOtherSchema where

884747 mempty = genericMempty

885− mappend = (<>)

748+ mappend = genericMappend

886749

887−instance Semigroup Header where

888− (<>) = genericMappend

889750instance Monoid Header where

890751 mempty = genericMempty

891− mappend = (<>)

752+ mappend = genericMappend

892753

893−instance Semigroup Responses where

894− (<>) = genericMappend

895754instance Monoid Responses where

896755 mempty = genericMempty

897− mappend = (<>)

756+ mappend = genericMappend

898757

899−instance Semigroup Response where

900− (<>) = genericMappend

901758instance Monoid Response where

902759 mempty = genericMempty

903− mappend = (<>)

760+ mappend = genericMappend

904761

905−instance Semigroup ExternalDocs where

906− (<>) = genericMappend

907762instance Monoid ExternalDocs where

908763 mempty = genericMempty

909− mappend = (<>)

764+ mappend = genericMappend

910765

911−instance Semigroup Operation where

912− (<>) = genericMappend

913766instance Monoid Operation where

914767 mempty = genericMempty

915− mappend = (<>)

768+ mappend = genericMappend

916769

917−instance Semigroup Example where

918− (<>) = genericMappend

919770instance Monoid Example where

920771 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 = (<>)

772+ mappend = genericMappend

933773

934774-- =======================================================================

935775-- SwaggerMonoid helper instances

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

945785instance SwaggerMonoid Response

946786instance SwaggerMonoid ExternalDocs

947787instance SwaggerMonoid Operation

948−instance SwaggerMonoid SecurityDefinitions

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

950788

951789instance SwaggerMonoid MimeList

952790deriving instance SwaggerMonoid URL

@@ -959,13 +797,13 @@ instance SwaggerMonoid ParamLocation where

959797 swaggerMempty = ParamQuery

960798 swaggerMappend _ y = y

961799

962−instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where

963− swaggerMempty = InsOrdHashMap.empty

964− swaggerMappend = InsOrdHashMap.unionWith mappend

800+instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where

801+ swaggerMempty = HashMap.empty

802+ swaggerMappend = HashMap.unionWith mappend

965803

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

967805 swaggerMempty = Inline mempty

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

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

969807 swaggerMappend _ y = y

970808

971809instance SwaggerMonoid ParamAnySchema where

@@ -1059,8 +897,7 @@ instance ToJSON OAuth2Flow where

1059897 , "tokenUrl" .= tokenUrl ]

1060898

1061899instance ToJSON OAuth2Params where

1062− toJSON = sopSwaggerGenericToJSON

1063− DEFINE_TOENCODING

900+ toJSON = omitEmpties . genericToJSONWithSub "flow" (jsonPrefix "oauth2")

1064901

1065902instance ToJSON SecuritySchemeType where

1066903 toJSON SecuritySchemeBasic

@@ -1073,37 +910,28 @@ instance ToJSON SecuritySchemeType where

1073910 <+> object [ "type" .= ("oauth2" :: Text) ]

1074911

1075912instance ToJSON Swagger where

1076− toJSON = sopSwaggerGenericToJSON

1077− DEFINE_TOENCODING

913+ toJSON = omitEmpties . addVersion . genericToJSON (jsonPrefix "swagger")

914+ where

915+ addVersion (Object o) = Object (HashMap.insert "swagger" "2.0" o)

916+ addVersion _ = error "impossible"

1078917

1079918instance ToJSON SecurityScheme where

1080− toJSON = sopSwaggerGenericToJSON

1081− DEFINE_TOENCODING

919+ toJSON = genericToJSONWithSub "type" (jsonPrefix "securityScheme")

1082920

1083921instance ToJSON Schema where

1084− toJSON = sopSwaggerGenericToJSON

1085− DEFINE_TOENCODING

922+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "paramSchema" (jsonPrefix "schema")

923+ where

924+ f "items" (Array _) = True

925+ f _ _ = False

1086926

1087927instance ToJSON Header where

1088− toJSON = sopSwaggerGenericToJSON

1089− DEFINE_TOENCODING

928+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "header")

1090929

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

1097−instance ToJSON (ParamSchema t) => ToJSON (SwaggerItems t) where

930+instance ToJSON (SwaggerItems t) where

1098931 toJSON (SwaggerItemsPrimitive fmt schema) = object

1099932 [ "collectionFormat" .= fmt

1100933 , "items" .= schema ]

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

1102− toJSON (SwaggerItemsArray []) = object

1103− [ "items" .= object []

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

1105− , "example" .= Array mempty

1106− ]

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

1108936

1109937instance ToJSON Host where

@@ -1116,39 +944,31 @@ instance ToJSON MimeList where

1116944 toJSON (MimeList xs) = toJSON (map show xs)

1117945

1118946instance ToJSON Param where

1119− toJSON = sopSwaggerGenericToJSON

1120− DEFINE_TOENCODING

947+ toJSON = genericToJSONWithSub "schema" (jsonPrefix "param")

1121948

1122949instance ToJSON ParamAnySchema where

1123950 toJSON (ParamBody s) = object [ "in" .= ("body" :: Text), "schema" .= s ]

1124951 toJSON (ParamOther s) = toJSON s

1125952

1126953instance ToJSON ParamOtherSchema where

1127− toJSON = sopSwaggerGenericToJSON

1128− DEFINE_TOENCODING

954+ toJSON = genericToJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")

1129955

1130956instance ToJSON Responses where

1131− toJSON = sopSwaggerGenericToJSON

1132− DEFINE_TOENCODING

957+ toJSON (Responses def rs) = omitEmpties $

958+ toJSON (hashMapMapKeys show rs) <+> object [ "default" .= def ]

1133959

1134960instance ToJSON Response where

1135− toJSON = sopSwaggerGenericToJSON

1136− DEFINE_TOENCODING

961+ toJSON = omitEmpties . genericToJSON (jsonPrefix "response")

1137962

1138963instance ToJSON Operation where

1139− toJSON = sopSwaggerGenericToJSON

1140− DEFINE_TOENCODING

964+ toJSON = omitEmpties . genericToJSON (jsonPrefix "operation")

1141965

1142966instance ToJSON PathItem where

1143− toJSON = sopSwaggerGenericToJSON

1144− DEFINE_TOENCODING

967+ toJSON = omitEmpties . genericToJSON (jsonPrefix "pathItem")

1145968

1146969instance ToJSON Example where

1147970 toJSON = toJSON . Map.mapKeys show . getExample

1148971

1149−instance ToJSON SecurityDefinitions where

1150− toJSON (SecurityDefinitions sd) = toJSON sd

1151−

1152972instance ToJSON Reference where

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

1154974

@@ -1177,14 +997,11 @@ instance ToJSON (CollectionFormat t) where

1177997 toJSON CollectionPipes = "pipes"

1178998 toJSON CollectionMulti = "multi"

1179999

1180−instance ToJSON (ParamSchema k) where

1181− -- TODO: this is a bit fishy, why we need sub object only in `ToJSON`?

1182− toJSON = sopSwaggerGenericToJSONWithOpts $

1183− mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

1184−

1185−instance ToJSON AdditionalProperties where

1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b

1187− toJSON (AdditionalPropertiesSchema s) = toJSON s

1000+instance ToJSON (ParamSchema t) where

1001+ toJSON = omitEmptiesExcept f . genericToJSONWithSub "items" (jsonPrefix "paramSchema")

1002+ where

1003+ f "items" (Array _) = True

1004+ f _ _ = False

11881005

11891006-- =======================================================================

11901007-- Manual FromJSON instances

@@ -1204,7 +1021,7 @@ instance FromJSON OAuth2Flow where

12041021 parseJSON _ = empty

12051022

12061023instance FromJSON OAuth2Params where

1207− parseJSON = sopSwaggerGenericParseJSON

1024+ parseJSON = genericParseJSONWithSub "flow" (jsonPrefix "oauth2")

12081025

12091026instance FromJSON SecuritySchemeType where

12101027 parseJSON js@(Object o) = do

@@ -1217,65 +1034,57 @@ instance FromJSON SecuritySchemeType where

12171034 parseJSON _ = empty

12181035

12191036instance FromJSON Swagger where

1220− parseJSON = sopSwaggerGenericParseJSON

1037+ parseJSON js@(Object o) = do

1038+ (version :: Text) <- o .: "swagger"

1039+ when (version /= "2.0") empty

1040+ (genericParseJSON (jsonPrefix "swagger")

1041+ `withDefaults` [ "consumes" .= (mempty :: MimeList)

1042+ , "produces" .= (mempty :: MimeList)

1043+ , "security" .= ([] :: [SecurityRequirement])

1044+ , "tags" .= ([] :: [Tag])

1045+ , "definitions" .= (mempty :: Definitions Schema)

1046+ , "parameters" .= (mempty :: Definitions Param)

1047+ , "responses" .= (mempty :: Definitions Response)

1048+ , "securityDefinitions" .= (mempty :: Definitions SecurityScheme)

1049+ ] ) js

1050+ parseJSON _ = empty

12211051

12221052instance FromJSON SecurityScheme where

1223− parseJSON = sopSwaggerGenericParseJSON

1053+ parseJSON = genericParseJSONWithSub "type" (jsonPrefix "securityScheme")

12241054

12251055instance 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

1056+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "schema")

1057+ `withDefaults` [ "properties" .= (mempty :: HashMap Text Schema)

1058+ , "required" .= ([] :: [ParamName]) ]

12331059

12341060instance FromJSON Header where

1235− parseJSON = sopSwaggerGenericParseJSON

1061+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "header")

12361062

1237−instance (FromJSON (CollectionFormat ('SwaggerKindNormal t)), FromJSON (ParamSchema ('SwaggerKindNormal t))) => FromJSON (SwaggerItems ('SwaggerKindNormal t)) where

1063+instance OVERLAPPABLE_ (FromJSON (CollectionFormat t), FromJSON (ParamSchema t)) => FromJSON (SwaggerItems t) where

12381064 parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive

12391065 <$> o .:? "collectionFormat"

12401066 <*> (o .: "items" >>= parseJSON)

12411067

1242−instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where

1243− parseJSON = withObject "SwaggerItemsPrimitive" $ \o -> SwaggerItemsPrimitive

1244− <$> o .:? "collectionFormat"

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

1246−

1247−-- |

1248−--

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

1250−-- Just (SwaggerItemsArray [])

1251−--

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

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

1254−--

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

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

1257−--

1258−instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1259− parseJSON js@(Object obj)

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

1261− | otherwise = SwaggerItemsObject <$> parseJSON js

1068+instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where

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

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

12631071 parseJSON _ = empty

12641072

12651073instance FromJSON Host where

1266− parseJSON (String s) = case map Text.unpack $ Text.split (== ':') s of

1267− [host] -> return $ Host host Nothing

1268− [host, port] -> case readMaybe port of

1269− Nothing -> fail $ "Invalid port `" ++ port ++ "'"

1270− Just p -> return $ Host host (Just (fromInteger p))

1271− _ -> fail $ "Invalid host `" ++ Text.unpack s ++ "'"

1074+ parseJSON (String s) =

1075+ case fromInteger <$> readMaybe portStr of

1076+ Nothing | not (null portStr) -> fail $ "Invalid port `" ++ portStr ++ "'"

1077+ mport -> pure $ Host host mport

1078+ where

1079+ (hostText, portText) = Text.breakOn ":" s

1080+ [host, portStr] = map Text.unpack [hostText, portText]

12721081 parseJSON _ = empty

12731082

12741083instance FromJSON MimeList where

12751084 parseJSON js = (MimeList . map fromString) <$> parseJSON js

12761085

12771086instance FromJSON Param where

1278− parseJSON = sopSwaggerGenericParseJSON

1087+ parseJSON = genericParseJSONWithSub "schema" (jsonPrefix "param")

12791088

12801089instance FromJSON ParamAnySchema where

12811090 parseJSON js@(Object o) = do

@@ -1288,12 +1097,12 @@ instance FromJSON ParamAnySchema where

12881097 parseJSON _ = empty

12891098

12901099instance FromJSON ParamOtherSchema where

1291− parseJSON = sopSwaggerGenericParseJSON

1100+ parseJSON = genericParseJSONWithSub "paramSchema" (jsonPrefix "paramOtherSchema")

12921101

12931102instance FromJSON Responses where

12941103 parseJSON (Object o) = Responses

12951104 <$> o .:? "default"

1296− <*> (parseJSON (Object (HashMap.delete "default" o)))

1105+ <*> (parseJSON (Object (HashMap.delete "default" o)) >>= hashMapReadKeys)

12971106 parseJSON _ = empty

12981107

12991108instance FromJSON Example where

@@ -1302,16 +1111,16 @@ instance FromJSON Example where

13021111 pure $ Example (Map.mapKeys fromString m)

13031112

13041113instance FromJSON Response where

1305− parseJSON = sopSwaggerGenericParseJSON

1114+ parseJSON = genericParseJSON (jsonPrefix "response")

1115+ `withDefaults` [ "headers" .= (mempty :: HashMap HeaderName Header) ]

13061116

13071117instance FromJSON Operation where

1308− parseJSON = sopSwaggerGenericParseJSON

1118+ parseJSON = genericParseJSON (jsonPrefix "operation")

1119+ `withDefaults` [ "security" .= ([] :: [SecurityRequirement]) ]

13091120

13101121instance FromJSON PathItem where

1311− parseJSON = sopSwaggerGenericParseJSON

1312−

1313−instance FromJSON SecurityDefinitions where

1314− parseJSON js = SecurityDefinitions <$> parseJSON js

1122+ parseJSON = genericParseJSON (jsonPrefix "pathItem")

1123+ `withDefaults` [ "parameters" .= ([] :: [Param]) ]

13151124

13161125instance FromJSON Reference where

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

@@ -1337,91 +1146,26 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#

13371146instance FromJSON Xml where

13381147 parseJSON = genericParseJSON (jsonPrefix "xml")

13391148

1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where

1149+instance FromJSON (SwaggerType Schema) where

13411150 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerNull, SwaggerObject]

13421151

1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where

1152+instance FromJSON (SwaggerType ParamOtherSchema) where

13441153 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray, SwaggerFile]

13451154

1346−instance FromJSON (SwaggerType ('SwaggerKindNormal t)) where

1155+instance OVERLAPPABLE_ FromJSON (SwaggerType t) where

13471156 parseJSON = parseOneOf [SwaggerString, SwaggerInteger, SwaggerNumber, SwaggerBoolean, SwaggerArray]

13481157

1349−instance FromJSON (CollectionFormat ('SwaggerKindNormal t)) where

1158+instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where

13501159 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]

13511160

1352−-- NOTE: There aren't collections of 'Schema'

1353−--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where

1354−-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]

1355−

1356−instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where

1161+instance FromJSON (CollectionFormat ParamOtherSchema) where

13571162 parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes, CollectionMulti]

13581163

1359−instance (FromJSON (SwaggerType ('SwaggerKindNormal t)), FromJSON (SwaggerItems ('SwaggerKindNormal t))) => FromJSON (ParamSchema ('SwaggerKindNormal t)) where

1360− parseJSON = sopSwaggerGenericParseJSON

1361−instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where

1362− parseJSON = sopSwaggerGenericParseJSON

1363−instance FromJSON (ParamSchema 'SwaggerKindSchema) where

1364− parseJSON = sopSwaggerGenericParseJSON

1365−

1366−instance FromJSON AdditionalProperties where

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

1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js

1369−

1370−-------------------------------------------------------------------------------

1371−-- TH splices

1372−-------------------------------------------------------------------------------

1373−

1374−deriveGeneric ''Header

1375−deriveGeneric ''OAuth2Params

1376−deriveGeneric ''Operation

1377−deriveGeneric ''Param

1378−deriveGeneric ''ParamOtherSchema

1379−deriveGeneric ''PathItem

1380−deriveGeneric ''Response

1381−deriveGeneric ''Responses

1382−deriveGeneric ''SecurityScheme

1383−deriveGeneric ''Schema

1384−deriveGeneric ''ParamSchema

1385−deriveGeneric ''Swagger

1386−

1387−instance HasSwaggerAesonOptions Header where

1388− swaggerAesonOptions _ = mkSwaggerAesonOptions "header" & saoSubObject ?~ "paramSchema"

1389−instance HasSwaggerAesonOptions OAuth2Params where

1390− swaggerAesonOptions _ = mkSwaggerAesonOptions "oauth2" & saoSubObject ?~ "flow"

1391−instance HasSwaggerAesonOptions Operation where

1392− swaggerAesonOptions _ = mkSwaggerAesonOptions "operation"

1393−instance HasSwaggerAesonOptions Param where

1394− swaggerAesonOptions _ = mkSwaggerAesonOptions "param" & saoSubObject ?~ "schema"

1395−instance HasSwaggerAesonOptions ParamOtherSchema where

1396− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramOtherSchema" & saoSubObject ?~ "paramSchema"

1397−instance HasSwaggerAesonOptions PathItem where

1398− swaggerAesonOptions _ = mkSwaggerAesonOptions "pathItem"

1399−instance HasSwaggerAesonOptions Response where

1400− swaggerAesonOptions _ = mkSwaggerAesonOptions "response"

1401−instance HasSwaggerAesonOptions Responses where

1402− swaggerAesonOptions _ = mkSwaggerAesonOptions "responses" & saoSubObject ?~ "responses"

1403−instance HasSwaggerAesonOptions SecurityScheme where

1404− swaggerAesonOptions _ = mkSwaggerAesonOptions "securityScheme" & saoSubObject ?~ "type"

1405−instance HasSwaggerAesonOptions Schema where

1406− swaggerAesonOptions _ = mkSwaggerAesonOptions "schema" & saoSubObject ?~ "paramSchema"

1407−instance HasSwaggerAesonOptions Swagger where

1408− swaggerAesonOptions _ = mkSwaggerAesonOptions "swagger" & saoAdditionalPairs .~ [("swagger", "2.0")]

1409−

1410−instance HasSwaggerAesonOptions (ParamSchema ('SwaggerKindNormal t)) where

1411− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

1412−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where

1413− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

1414−-- NOTE: Schema doesn't have 'items' sub object!

1415−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where

1416− swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"

1417−

1418−instance AesonDefaultValue (ParamSchema s)

1419−instance AesonDefaultValue OAuth2Flow

1420−instance AesonDefaultValue Responses

1421−instance AesonDefaultValue ParamAnySchema

1422−instance AesonDefaultValue SecuritySchemeType

1423−instance AesonDefaultValue (SwaggerType a)

1424−instance AesonDefaultValue MimeList where defaultValue = Just mempty

1425−instance AesonDefaultValue Info

1426−instance AesonDefaultValue ParamLocation

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

1164+-- NOTE: The constraints @FromJSON (SwaggerType t)@ and

1165+-- @FromJSON (SwaggerItems t)@ are necessary here!

1166+-- Without the constraint the general instance will be used

1167+-- that only accepts common types (i.e. NOT object, null or file)

1168+-- and primitive array items.

1169+instance (FromJSON (SwaggerType t), FromJSON (SwaggerItems t)) => FromJSON (ParamSchema t) where

1170+ parseJSON = genericParseJSONWithSub "items" (jsonPrefix "ParamSchema")

1171+

src/Data/Swagger/Internal/AesonUtils.hsdeleted−346

@@ -1,346 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE ExplicitForAll #-}

7−{-# LANGUAGE TemplateHaskell #-}

8−#if __GLASGOW_HASKELL__ >= 800

9−{-# LANGUAGE UndecidableSuperClasses #-}

10−#endif

11−module Data.Swagger.Internal.AesonUtils (

12− -- * Generic functions

13− AesonDefaultValue(..),

14− sopSwaggerGenericToJSON,

15−#if MIN_VERSION_aeson(0,10,0)

16− sopSwaggerGenericToEncoding,

17−#endif

18− sopSwaggerGenericToJSONWithOpts,

19− sopSwaggerGenericParseJSON,

20− -- * Options

21− HasSwaggerAesonOptions(..),

22− SwaggerAesonOptions,

23− mkSwaggerAesonOptions,

24− saoPrefix,

25− saoAdditionalPairs,

26− saoSubObject,

27− ) where

28−

29−import Prelude ()

30−import Prelude.Compat

31−

32−import Control.Applicative ((<|>))

33−import Control.Lens (makeLenses, (^.))

34−import Control.Monad (unless)

35−import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject)

36−import Data.Aeson.Types (Parser, Pair)

37−import Data.Char (toLower, isUpper)

38−import Data.Foldable (traverse_)

39−import Data.Text (Text)

40−

41−import Generics.SOP

42−

43−import qualified Data.Text as T

44−import qualified Data.HashMap.Strict as HM

45−import qualified Data.Set as Set

46−import qualified Data.HashMap.Strict.InsOrd as InsOrd

47−import qualified Data.HashSet.InsOrd as InsOrdHS

48−

49−#if MIN_VERSION_aeson(0,10,0)

50−import Data.Aeson (Encoding, pairs, (.=), Series)

51−#endif

52−

53−-------------------------------------------------------------------------------

54−-- SwaggerAesonOptions

55−-------------------------------------------------------------------------------

56−

57−data SwaggerAesonOptions = SwaggerAesonOptions

58− { _saoPrefix :: String

59− , _saoAdditionalPairs :: [(Text, Value)]

60− , _saoSubObject :: Maybe String

61− }

62−

63−mkSwaggerAesonOptions

64− :: String -- ^ prefix

65− -> SwaggerAesonOptions

66−mkSwaggerAesonOptions pfx = SwaggerAesonOptions pfx [] Nothing

67−

68−makeLenses ''SwaggerAesonOptions

69−

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

71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

72−

73− -- So far we use only default definitions

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

75− aesonDefaults _ = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue

76−

77−-------------------------------------------------------------------------------

78−-- Generics

79−-------------------------------------------------------------------------------

80−

81−class AesonDefaultValue a where

82− defaultValue :: Maybe a

83− defaultValue = Nothing

84−

85−instance AesonDefaultValue Text where defaultValue = Nothing

86−instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing

87−instance AesonDefaultValue [a] where defaultValue = Just []

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

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

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

91−

92−-------------------------------------------------------------------------------

93−-- ToJSON

94−-------------------------------------------------------------------------------

95−

96−-- | Generic serialisation for swagger records.

97−--

98−-- Features

99−--

100−-- * omits nulls, empty objects and empty arrays (configurable)

101−-- * possible to add fields

102−-- * possible to merge sub-object

103−sopSwaggerGenericToJSON

104− :: forall a xs.

105− ( HasDatatypeInfo a

106− , HasSwaggerAesonOptions a

107− , All2 ToJSON (Code a)

108− , All2 Eq (Code a)

109− , Code a ~ '[xs]

110− )

111− => a

112− -> Value

113−sopSwaggerGenericToJSON x =

114− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)

115− in object (opts ^. saoAdditionalPairs ++ ps)

116− where

117− proxy = Proxy :: Proxy a

118− opts = swaggerAesonOptions proxy

119−

120−-- | *TODO:* This is only used by ToJSON (ParamSchema SwaggerKindSchema)

121−--

122−-- Also uses default `aesonDefaults`

123−sopSwaggerGenericToJSONWithOpts

124− :: forall a xs.

125− ( Generic a

126− , All2 AesonDefaultValue (Code a)

127− , HasDatatypeInfo a

128− , All2 ToJSON (Code a)

129− , All2 Eq (Code a)

130− , Code a ~ '[xs]

131− )

132− => SwaggerAesonOptions

133− -> a

134− -> Value

135−sopSwaggerGenericToJSONWithOpts opts x =

136− let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs

137− in object (opts ^. saoAdditionalPairs ++ ps)

138− where

139− proxy = Proxy :: Proxy a

140− defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue

141−

142−sopSwaggerGenericToJSON'

143− :: (All2 ToJSON '[xs], All2 Eq '[xs])

144− => SwaggerAesonOptions

145− -> SOP I '[xs]

146− -> DatatypeInfo '[xs]

147− -> POP Maybe '[xs]

148− -> [Pair]

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

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

151−#else

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

153−#endif

154− sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

155−sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"

156−

157−sopSwaggerGenericToJSON''

158− :: (All ToJSON xs, All Eq xs)

159− => SwaggerAesonOptions

160− -> NP I xs

161− -> NP FieldInfo xs

162− -> NP Maybe xs

163− -> [Pair]

164−sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

165− where

166− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> [Pair]

167− go Nil Nil Nil = []

168− go (I x :* xs) (FieldInfo name :* names) (def :* defs)

169− | Just name' == sub = case json of

170− Object m -> HM.toList m ++ rest

171− Null -> rest

172− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json

173− -- If default value: omit it.

174− | Just x == def =

175− rest

176− | otherwise =

177− (T.pack name', json) : rest

178− where

179− json = toJSON x

180− name' = fieldNameModifier name

181− rest = go xs names defs

182−#if __GLASGOW_HASKELL__ < 800

183− go _ _ _ = error "not empty"

184−#endif

185−

186− fieldNameModifier = modifier . drop 1

187− modifier = lowerFirstUppers . drop (length prefix)

188− lowerFirstUppers s = map toLower x ++ y

189− where (x, y) = span isUpper s

190−

191−-------------------------------------------------------------------------------

192−-- FromJSON

193−-------------------------------------------------------------------------------

194−

195−sopSwaggerGenericParseJSON

196− :: forall a xs.

197− ( HasDatatypeInfo a

198− , HasSwaggerAesonOptions a

199− , All2 FromJSON (Code a)

200− , All2 Eq (Code a)

201− , Code a ~ '[xs]

202− )

203− => Value

204− -> Parser a

205−sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->

206− let ps = sopSwaggerGenericParseJSON' opts obj (datatypeInfo proxy) (aesonDefaults proxy)

207− in do

208− traverse_ (parseAdditionalField obj) (opts ^. saoAdditionalPairs)

209− to <$> ps

210− where

211− proxy = Proxy :: Proxy a

212− opts = swaggerAesonOptions proxy

213−

214− parseAdditionalField :: Object -> (Text, Value) -> Parser ()

215− parseAdditionalField obj (k, v) = do

216− v' <- obj .: k

217− unless (v == v') $ fail $

218− "Additonal field don't match for key " ++ T.unpack k

219− ++ ": " ++ show v

220− ++ " /= " ++ show v'

221−

222−sopSwaggerGenericParseJSON'

223− :: (All2 FromJSON '[xs], All2 Eq '[xs])

224− => SwaggerAesonOptions

225− -> Object

226− -> DatatypeInfo '[xs]

227− -> POP Maybe '[xs]

228− -> Parser (SOP I '[xs])

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

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

231−#else

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

233−#endif

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

235−sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"

236−

237−sopSwaggerGenericParseJSON''

238− :: (All FromJSON xs, All Eq xs)

239− => SwaggerAesonOptions

240− -> Object

241− -> NP FieldInfo xs

242− -> NP Maybe xs

243− -> Parser (NP I xs)

244−sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go

245− where

246− go :: (All FromJSON ys, All Eq ys) => NP FieldInfo ys -> NP Maybe ys -> Parser (NP I ys)

247− go Nil Nil = pure Nil

248− go (FieldInfo name :* names) (def :* defs)

249− | Just name' == sub =

250− -- Note: we might strip fields of outer structure.

251− cons <$> (withDef $ parseJSON $ Object obj) <*> rest

252− | otherwise = case def of

253− Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest

254− Nothing -> cons <$> obj .: T.pack name' <*> rest

255− where

256− cons h t = I h :* t

257− name' = fieldNameModifier name

258− rest = go names defs

259−

260− withDef = case def of

261− Just def' -> (<|> pure def')

262− Nothing -> id

263−#if __GLASGOW_HASKELL__ < 800

264− go _ _ = error "not empty"

265−#endif

266−

267− fieldNameModifier = modifier . drop 1

268− modifier = lowerFirstUppers . drop (length prefix)

269− lowerFirstUppers s = map toLower x ++ y

270− where (x, y) = span isUpper s

271−

272−-------------------------------------------------------------------------------

273−-- ToEncoding

274−-------------------------------------------------------------------------------

275−

276−#if MIN_VERSION_aeson(0,10,0)

277−

278−sopSwaggerGenericToEncoding

279− :: forall a xs.

280− ( HasDatatypeInfo a

281− , HasSwaggerAesonOptions a

282− , All2 ToJSON (Code a)

283− , All2 Eq (Code a)

284− , Code a ~ '[xs]

285− )

286− => a

287− -> Encoding

288−sopSwaggerGenericToEncoding x =

289− let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy)

290− in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps)

291− where

292− proxy = Proxy :: Proxy a

293− opts = swaggerAesonOptions proxy

294−

295−pairsToSeries :: [Pair] -> Series

296−pairsToSeries = foldMap (\(k, v) -> (k .= v))

297−

298−sopSwaggerGenericToEncoding'

299− :: (All2 ToJSON '[xs], All2 Eq '[xs])

300− => SwaggerAesonOptions

301− -> SOP I '[xs]

302− -> DatatypeInfo '[xs]

303− -> POP Maybe '[xs]

304− -> Series

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

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

307−#else

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

309−#endif

310− sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

311−sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"

312−

313−sopSwaggerGenericToEncoding''

314− :: (All ToJSON xs, All Eq xs)

315− => SwaggerAesonOptions

316− -> NP I xs

317− -> NP FieldInfo xs

318− -> NP Maybe xs

319− -> Series

320−sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go

321− where

322− go :: (All ToJSON ys, All Eq ys) => NP I ys -> NP FieldInfo ys -> NP Maybe ys -> Series

323− go Nil Nil Nil = mempty

324− go (I x :* xs) (FieldInfo name :* names) (def :* defs)

325− | Just name' == sub = case toJSON x of

326− Object m -> pairsToSeries (HM.toList m) <> rest

327− Null -> rest

328− _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x)

329− -- If default value: omit it.

330− | Just x == def =

331− rest

332− | otherwise =

333− (T.pack name' .= x) <> rest

334− where

335− name' = fieldNameModifier name

336− rest = go xs names defs

337−#if __GLASGOW_HASKELL__ < 800

338− go _ _ _ = error "not empty"

339−#endif

340−

341− fieldNameModifier = modifier . drop 1

342− modifier = lowerFirstUppers . drop (length prefix)

343− lowerFirstUppers s = map toLower x ++ y

344− where (x, y) = span isUpper s

345−

346−#endif

src/Data/Swagger/Internal/ParamSchema.hs+23−120

@@ -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,50 +22,15 @@ 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

38−import qualified Data.Vector as V

39−import qualified Data.Vector.Primitive as VP

40−import qualified Data.Vector.Storable as VS

41−import qualified Data.Vector.Unboxed as VU

42−import Data.Version (Version)

43−import Numeric.Natural.Compat (Natural)

4428import Data.Word

45−import Data.UUID.Types (UUID)

46−import Web.Cookie (SetCookie)

4729

4830import Data.Swagger.Internal

4931import Data.Swagger.Lens

5032import Data.Swagger.SchemaOptions

5133

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−

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

60−binaryParamSchema :: ParamSchema t

61−binaryParamSchema = mempty

62− & type_ ?~ SwaggerString

63− & format ?~ "binary"

64−

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

66−byteParamSchema :: ParamSchema t

67−byteParamSchema = mempty

68− & type_ ?~ SwaggerString

69− & format ?~ "byte"

70−

71−-- | Default schema for password string.

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

73−passwordParamSchema :: ParamSchema t

74−passwordParamSchema = mempty

75− & type_ ?~ SwaggerString

76− & format ?~ "password"

77−

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

7935--

8036-- An example type and instance:

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

8743-- data Direction = Up | Down

8844--

8945-- instance ToParamSchema Direction where

90−-- toParamSchema _ = mempty

91−-- & type_ ?~ SwaggerString

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

46+-- toParamSchema = mempty

47+-- & type_ .~ SwaggerString

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

9349-- @

9450--

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

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

11571 --

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

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

118− toParamSchema :: Proxy a -> ParamSchema t

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

74+ toParamSchema :: proxy a -> ParamSchema t

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

12076 toParamSchema = genericToParamSchema defaultSchemaOptions

12177

12278instance OVERLAPPING_ ToParamSchema String where

123− toParamSchema _ = mempty & type_ ?~ SwaggerString

79+ toParamSchema _ = mempty & type_ .~ SwaggerString

12480

12581instance ToParamSchema Bool where

126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

82+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean

12783

12884instance 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

85+ toParamSchema _ = mempty & type_ .~ SwaggerInteger

13686

13787instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral

13888instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral

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

154104--

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

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

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

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

158108toParamSchemaBoundedIntegral _ = mempty

159− & type_ ?~ SwaggerInteger

109+ & type_ .~ SwaggerInteger

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

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

162112

163113instance ToParamSchema Char where

164114 toParamSchema _ = mempty

165− & type_ ?~ SwaggerString

115+ & type_ .~ SwaggerString

166116 & maxLength ?~ 1

167117 & minLength ?~ 1

168118

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

120+ toParamSchema _ = mempty & type_ .~ SwaggerNumber

176121

177122instance ToParamSchema Double where

178123 toParamSchema _ = mempty

179− & type_ ?~ SwaggerNumber

124+ & type_ .~ SwaggerNumber

180125 & format ?~ "double"

181126

182127instance ToParamSchema Float where

183128 toParamSchema _ = mempty

184− & type_ ?~ SwaggerNumber

129+ & type_ .~ SwaggerNumber

185130 & format ?~ "float"

186131

187132timeParamSchema :: String -> ParamSchema t

188133timeParamSchema fmt = mempty

189− & type_ ?~ SwaggerString

134+ & type_ .~ SwaggerString

190135 & format ?~ T.pack fmt

191136

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

193138instance ToParamSchema Day where

194139 toParamSchema _ = timeParamSchema "date"

195140

196−-- |

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

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

199−instance ToParamSchema TimeOfDay where

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

201−

202141-- |

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

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

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

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

219158

220159instance ToParamSchema NominalDiffTime where

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

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

222161

223162instance ToParamSchema T.Text where

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

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

226165instance ToParamSchema TL.Text where

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

228167

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−

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

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

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

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

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

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

258175

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

260−

261176instance ToParamSchema a => ToParamSchema [a] where

262177 toParamSchema _ = mempty

263− & type_ ?~ SwaggerArray

178+ & type_ .~ SwaggerArray

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

265180

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

267−instance ToParamSchema a => ToParamSchema (VP.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])

268−instance ToParamSchema a => ToParamSchema (VS.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])

269−instance ToParamSchema a => ToParamSchema (VU.Vector a) where toParamSchema _ = toParamSchema (Proxy :: Proxy [a])

270−

271181instance ToParamSchema a => ToParamSchema (Set a) where

272182 toParamSchema _ = toParamSchema (Proxy :: Proxy [a])

273183 & uniqueItems ?~ True

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

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

281191instance ToParamSchema () where

282192 toParamSchema _ = mempty

283− & type_ ?~ SwaggerString

193+ & type_ .~ SwaggerString

284194 & enum_ ?~ ["_"]

285195

286−instance ToParamSchema UUID where

287− toParamSchema _ = mempty

288− & type_ ?~ SwaggerString

289− & format ?~ "uuid"

290−

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

292197--

293198-- >>> :set -XDeriveGeneric

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

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

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

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

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

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

299204

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

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

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

302207

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

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

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

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

317222

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

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

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

320225

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

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

323228

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

325230 genumParamSchema opts _ s = s

326− & type_ ?~ SwaggerString

231+ & type_ .~ SwaggerString

327232 & enum_ %~ addEnumValue tag

328233 where

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

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

333238

334239data Proxy3 a b c = Proxy3

335240

336−-- $setup

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

src/Data/Swagger/Internal/Schema.hs+81−386

@@ -1,10 +1,8 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

32{-# LANGUAGE DefaultSignatures #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE KindSignatures #-}

7−{-# LANGUAGE DataKinds #-}

86{-# LANGUAGE OverloadedLists #-}

97{-# LANGUAGE OverloadedStrings #-}

108{-# LANGUAGE PackageImports #-}

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

1412{-# LANGUAGE TypeFamilies #-}

1513{-# LANGUAGE TypeOperators #-}

1614{-# 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

2415#include "overlapping-compat.h"

2516module Data.Swagger.Internal.Schema where

2617

@@ -32,50 +23,34 @@ import Data.Data.Lens (template)

3223

3324import Control.Monad

3425import Control.Monad.Writer

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

26+import Data.Aeson

3627import Data.Char

3728import Data.Data (Data)

3829import Data.Foldable (traverse_)

3930import Data.HashMap.Strict (HashMap)

4031import qualified Data.HashMap.Strict as HashMap

41−import "unordered-containers" Data.HashSet (HashSet)

42−import qualified "unordered-containers" Data.HashSet as HashSet

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

32+import "unordered-containers" Data.HashSet (HashSet)

4433import Data.Int

4534import Data.IntSet (IntSet)

4635import Data.IntMap (IntMap)

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

4836import Data.Map (Map)

4937import Data.Proxy

5038import Data.Scientific (Scientific)

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

5239import Data.Set (Set)

5340import qualified Data.Text as T

5441import qualified Data.Text.Lazy as TL

5542import Data.Time

56−import qualified Data.Vector as V

57−import qualified Data.Vector.Primitive as VP

58−import qualified Data.Vector.Storable as VS

59−import qualified Data.Vector.Unboxed as VU

60−import Data.Version (Version)

61−import Numeric.Natural.Compat (Natural)

6243import Data.Word

6344import GHC.Generics

64−import qualified Data.UUID.Types as UUID

6545

6646import Data.Swagger.Declare

6747import Data.Swagger.Internal

6848import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))

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

70−import qualified Data.Swagger.Lens as Swagger

7150import Data.Swagger.SchemaOptions

72−import Data.Swagger.Internal.TypeShape

7351

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

52+#ifdef __DOCTEST__

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

7954#endif

8055

8156unnamed :: Schema -> NamedSchema

@@ -102,21 +77,19 @@ rename name (NamedSchema _ schema) = NamedSchema name schema

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

10378--

10479-- import Control.Lens

105−-- import Data.Proxy

106−-- import Data.Swagger

10780--

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

10982--

11083-- instance ToSchema Coord where

111−-- declareNamedSchema _ = do

112−-- doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)

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

114−-- & type_ ?~ SwaggerObject

115−-- & properties .~

116−-- [ (\"x\", doubleSchema)

117−-- , (\"y\", doubleSchema)

118−-- ]

119−-- & required .~ [ \"x\", \"y\" ]

84+-- declareNamedSchema = pure (Just \"Coord\", schema)

85+-- where

86+-- schema = mempty

87+-- & type_ .~ SwaggerObject

88+-- & properties .~

89+-- [ (\"x\", toSchemaRef (Proxy :: Proxy Double))

90+-- , (\"y\", toSchemaRef (Proxy :: Proxy Double))

91+-- ]

92+-- & required .~ [ \"x\", \"y\" ]

12093-- @

12194--

12295-- Instead of manually writing your @'ToSchema'@ instance you can

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

142115 -- together with all used definitions.

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

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

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

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

148120 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

149121

150−instance ToSchema TimeOfDay where

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

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

153−

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

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

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

156124declareSchema = fmap _namedSchemaSchema . declareNamedSchema

157125

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

@@ -165,8 +133,8 @@ declareSchema = fmap _namedSchemaSchema . declareNamedSchema

165133-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name

166134-- Just "Day"

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

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

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

136+-- "{\"format\":\"date\",\"type\":\"string\"}"

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

170138toNamedSchema = undeclare . declareNamedSchema

171139

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

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

176144--

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

178146-- Just "UTCTime"

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

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

180148schemaName = _namedSchemaName . toNamedSchema

181149

182150-- | Convert a type into a schema.

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

186154--

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

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

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

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

190158toSchema = _namedSchemaSchema . toNamedSchema

191159

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

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

197165--

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

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

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

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

201169toSchemaRef = undeclare . declareSchemaRef

202170

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

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

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

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

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

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

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

211179declareSchemaRef proxy = do

212180 case toNamedSchema proxy of

213181 NamedSchema (Just name) schema -> do

@@ -219,7 +187,7 @@ declareSchemaRef proxy = do

219187 -- have already declared it.

220188 -- If we have, we don't need to declare anything for

221189 -- this schema this time and thus simply return the reference.

222− known <- looks (InsOrdHashMap.member name)

190+ known <- looks (HashMap.member name)

223191 when (not known) $ do

224192 declare [(name, schema)]

225193 void $ declareNamedSchema proxy

@@ -238,7 +206,7 @@ inlineSchemasWhen p defs = template %~ deref

238206 where

239207 deref r@(Ref (Reference name))

240208 | p name =

241− case InsOrdHashMap.lookup name defs of

209+ case HashMap.lookup name defs of

242210 Just schema -> Inline (inlineSchemasWhen p defs schema)

243211 Nothing -> r

244212 | otherwise = r

@@ -265,11 +233,11 @@ inlineAllSchemas = inlineSchemasWhen (const True)

265233-- | Convert a type into a schema without references.

266234--

267235-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])

268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"

236+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"

269237--

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

271239-- when inlining recursive schemas.

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

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

273241toInlinedSchema proxy = inlineAllSchemas defs schema

274242 where

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

@@ -280,7 +248,7 @@ inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s

280248inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs

281249 where

282250 nonRecursive name =

283− case InsOrdHashMap.lookup name defs of

251+ case HashMap.lookup name defs of

284252 Just schema -> name `notElem` execDeclare (usedNames schema) mempty

285253 Nothing -> False

286254

@@ -292,141 +260,22 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs

292260 seen <- looks (name `elem`)

293261 when (not seen) $ do

294262 declare [name]

295− traverse_ usedNames (InsOrdHashMap.lookup name defs)

263+ traverse_ usedNames (HashMap.lookup name defs)

296264 Inline subschema -> usedNames subschema

297265

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

299−binarySchema :: Schema

300−binarySchema = mempty

301− & type_ ?~ SwaggerString

302− & format ?~ "binary"

303−

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

305−byteSchema :: Schema

306−byteSchema = mempty

307− & type_ ?~ SwaggerString

308− & format ?~ "byte"

309−

310−-- | Default schema for password string.

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

312−passwordSchema :: Schema

313−passwordSchema = mempty

314− & type_ ?~ SwaggerString

315− & format ?~ "password"

316−

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

318−-- Produced schema can be used for further refinement.

319−--

320−-- >>> encode $ sketchSchema "hello"

321−-- "{\"example\":\"hello\",\"type\":\"string\"}"

322−--

323−-- >>> encode $ sketchSchema (1, 2, 3)

324−-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"

325−--

326−-- >>> encode $ sketchSchema ("Jack", 25)

327−-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"

328−--

329−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)

330−-- >>> instance ToJSON Person

331−-- >>> encode $ sketchSchema (Person "Jack" 25)

332−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"

333−sketchSchema :: ToJSON a => a -> Schema

334−sketchSchema = sketch . toJSON

335− where

336− sketch Null = go Null

337− sketch js@(Bool _) = go js

338− sketch js = go js & example ?~ js

339−

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

346− & items ?~ case ischema of

347− Just s -> SwaggerItemsObject (Inline s)

348− _ -> SwaggerItemsArray (map Inline ys)

349− where

350− ys = map go (V.toList xs)

351− allSame = and ((zipWith (==)) ys (tail ys))

352−

353− ischema = case ys of

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

355− _ -> Nothing

356− go (Object o) = mempty

357− & type_ ?~ SwaggerObject

358− & required .~ HashMap.keys o

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

360−

361−-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.

362−-- Produced schema uses as much constraints as possible.

363−--

364−-- >>> encode $ sketchStrictSchema "hello"

365−-- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}"

366−--

367−-- >>> encode $ sketchStrictSchema (1, 2, 3)

368−-- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}"

369−--

370−-- >>> encode $ sketchStrictSchema ("Jack", 25)

371−-- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}"

372−--

373−-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)

374−-- >>> instance ToJSON Person

375−-- >>> encode $ sketchStrictSchema (Person "Jack" 25)

376−-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}"

377−sketchStrictSchema :: ToJSON a => a -> Schema

378−sketchStrictSchema = go . toJSON

379− where

380− go Null = mempty & type_ ?~ SwaggerNull

381− go js@(Bool _) = mempty

382− & type_ ?~ SwaggerBoolean

383− & enum_ ?~ [js]

384− go js@(String s) = mempty

385− & type_ ?~ SwaggerString

386− & maxLength ?~ fromIntegral (T.length s)

387− & minLength ?~ fromIntegral (T.length s)

388− & pattern ?~ s

389− & enum_ ?~ [js]

390− go js@(Number n) = mempty

391− & type_ ?~ SwaggerNumber

392− & maximum_ ?~ n

393− & minimum_ ?~ n

394− & multipleOf ?~ n

395− & enum_ ?~ [js]

396− go js@(Array xs) = mempty

397− & type_ ?~ SwaggerArray

398− & maxItems ?~ fromIntegral sz

399− & minItems ?~ fromIntegral sz

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

401− & uniqueItems ?~ allUnique

402− & enum_ ?~ [js]

403− where

404− sz = length xs

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

406− go js@(Object o) = mempty

407− & type_ ?~ SwaggerObject

408− & required .~ names

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

410− & maxProperties ?~ fromIntegral (length names)

411− & minProperties ?~ fromIntegral (length names)

412− & enum_ ?~ [js]

413− where

414− names = HashMap.keys o

415−

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

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

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

418268

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

420270 declareNamedSchema _ = do

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

422272 return $ unnamed $ mempty

423− & type_ ?~ SwaggerArray

273+ & type_ .~ SwaggerArray

424274 & items ?~ SwaggerItemsObject ref

425275

426276instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

427277instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema

428278instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema

429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema

430279instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema

431280instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema

432281instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema

@@ -438,16 +287,11 @@ instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema

438287instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema

439288instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema

440289

441−instance ToSchema Char where

442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)

443− & mapped.Swagger.schema.example ?~ toJSON '?'

444−

290+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema

445291instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema

446292instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema

447293instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema

448294

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

450−

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

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

453297

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

456300instance ToSchema () where

457301 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)

458302

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−

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

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

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

@@ -470,81 +309,46 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f

470309

471310timeSchema :: T.Text -> Schema

472311timeSchema fmt = mempty

473− & type_ ?~ SwaggerString

312+ & type_ .~ SwaggerString

474313 & format ?~ fmt

475314

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

477316instance ToSchema Day where

478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"

479− & example ?~ toJSON (fromGregorian 2016 7 22)

317+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")

480318

481319-- |

482320-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format

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

484322instance ToSchema LocalTime where

485− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"

486− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))

323+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")

487324

488325-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.

489326instance ToSchema ZonedTime where

490327 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"

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

492328

493329instance ToSchema NominalDiffTime where

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

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

495331

496332-- |

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

498334-- Just "yyyy-mm-ddThh:MM:ssZ"

499335instance ToSchema UTCTime where

500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"

501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)

336+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")

502337

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

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

505340

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−

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

521342

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

523344instance ToSchema a => ToSchema (IntMap a) where

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

525346

526−#if MIN_VERSION_aeson(1,0,0)

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

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

529− ToJSONKeyText _ _ -> declareObjectMapSchema

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

531− where

532− declareObjectMapSchema = do

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

534− return $ unnamed $ mempty

535− & type_ ?~ SwaggerObject

536− & additionalProperties ?~ AdditionalPropertiesSchema schema

537−

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

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

540−

541−#else

542−

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

544348 declareNamedSchema _ = do

545− schema <- declareSchemaRef (Proxy :: Proxy a)

349+ schema <- declareSchema (Proxy :: Proxy a)

546350 return $ unnamed $ mempty

547− & type_ ?~ SwaggerObject

351+ & type_ .~ SwaggerObject

548352 & additionalProperties ?~ schema

549353

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

@@ -554,19 +358,6 @@ instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ =

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

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

556360

557−#endif

558−

559−instance OVERLAPPING_ ToSchema Object where

560− declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty

561− & type_ ?~ SwaggerObject

562− & description ?~ "Arbitrary JSON object."

563− & additionalProperties ?~ AdditionalPropertiesAllowed True

564−

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

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

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

568−instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

569−

570361instance ToSchema a => ToSchema (Set a) where

571362 declareNamedSchema _ = do

572363 schema <- declareSchema (Proxy :: Proxy [a])

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

575366

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

577368

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−

585369instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema

586370instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

587371

@@ -591,147 +375,67 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname

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

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

593377

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

595−

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

597379--

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

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

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

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

601383toSchemaBoundedIntegral _ = mempty

602− & type_ ?~ SwaggerInteger

384+ & type_ .~ SwaggerInteger

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

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

605387

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

607−genericToNamedSchemaBoundedIntegral :: forall a d f.

389+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

608390 ( Bounded a, Integral a

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

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

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

611393genericToNamedSchemaBoundedIntegral 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

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

668395

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

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

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

673399

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

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

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

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

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

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

681406

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

702−

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

704−gdatatypeSchemaName opts _ = case orig of

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

408+gdatatypeSchemaName opts _ = case name of

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

706410 _ -> Nothing

707411 where

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

709− name = datatypeNameModifier opts orig

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

710413

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

415+paramSchemaToNamedSchema :: forall a d f proxy.

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

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

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

715419

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

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

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

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

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

719423

720424nullarySchema :: Schema

721425nullarySchema = mempty

722− & type_ ?~ SwaggerArray

426+ & type_ .~ SwaggerArray

723427 & items ?~ SwaggerItemsArray []

724428

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

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

726430gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

727431

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

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

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

730434

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

732436 gdeclareNamedSchema opts _ schema = do

733− NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema

734− gdeclareNamedSchema opts (Proxy :: Proxy g) gschema

437+ NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy g) schema

438+ gdeclareNamedSchema opts (Proxy :: Proxy f) gschema

735439

736440instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where

737441 gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s

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

745449 gdeclareNamedSchema = gdeclareNamedSumSchema

746450

747451-- | Single field constructor.

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

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

749453 gdeclareNamedSchema opts _ s

750454 | unwrapUnaryRecords opts = fieldSchema

751455 | otherwise =

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

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

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

761465

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

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

763467gdeclareSchemaRef opts proxy = do

764468 case gtoNamedSchema opts proxy of

765469 NamedSchema (Just name) schema -> do

@@ -771,16 +475,16 @@ gdeclareSchemaRef opts proxy = do

771475 -- have already declared it.

772476 -- If we have, we don't need to declare anything for

773477 -- this schema this time and thus simply return the reference.

774− known <- looks (InsOrdHashMap.member name)

478+ known <- looks (HashMap.member name)

775479 when (not known) $ do

776480 declare [(name, schema)]

777481 void $ gdeclareNamedSchema opts proxy mempty

778482 return $ Ref (Reference name)

779483 _ -> Inline <$> gdeclareSchema opts proxy

780484

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

485+appendItem :: Referenced Schema -> Maybe (SwaggerItems Schema) -> Maybe (SwaggerItems Schema)

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

783−appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))

487+appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (x:xs))

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

785489

786490withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>

@@ -790,15 +494,13 @@ withFieldSchema opts _ isRequiredField schema = do

790494 return $

791495 if T.null fname

792496 then schema

793− & type_ ?~ SwaggerArray

497+ & type_ .~ SwaggerArray

794498 & items %~ appendItem ref

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

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

797499 else schema

798− & type_ ?~ SwaggerObject

500+ & type_ .~ SwaggerObject

799501 & properties . at fname ?~ ref

800502 & if isRequiredField

801− then required %~ (++ [fname])

503+ then required %~ (fname :)

802504 else id

803505 where

804506 fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))

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

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

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

819521

820−instance ( GSumToSchema f

821− , GSumToSchema g

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

823− where

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

824523 gdeclareNamedSchema = gdeclareNamedSumSchema

825524

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

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

827526gdeclareNamedSumSchema opts proxy s

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

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

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

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

833532

834533 toStringTag schema = mempty

835− & type_ ?~ SwaggerString

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

534+ & type_ .~ SwaggerString

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

837536

838537type AllNullary = All

839538

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

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

539+class GSumToSchema f where

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

842541

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

844− gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)

543+ gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) <=< gsumToSchema opts (Proxy :: Proxy g)

845544

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

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

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

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

848547gsumConToSchemaWith ref opts _ schema = schema

849− & type_ ?~ SwaggerObject

548+ & type_ .~ SwaggerObject

850549 & properties . at tag ?~ ref

851550 & maxProperties ?~ 1

852551 & minProperties ?~ 1

853552 where

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

855554

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

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

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

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

858557gsumConToSchema opts proxy schema = do

859558 ref <- gdeclareSchemaRef opts proxy

860559 return $ gsumConToSchemaWith ref opts proxy schema

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

876575

877576data Proxy3 a b c = Proxy3

878577

879−-- $setup

880−-- >>> import Data.Swagger

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

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

src/Data/Swagger/Internal/Schema/Validation.hsdeleted−511

@@ -1,511 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE LambdaCase #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PackageImports #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TemplateHaskell #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−-- |

16−-- Module: Data.Swagger.Internal.Schema.Validation

18−-- License: BSD3

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

20−-- Stability: experimental

21−--

22−-- Validate JSON values with Swagger Schema.

23−module Data.Swagger.Internal.Schema.Validation where

24−

25−import Prelude ()

26−import Prelude.Compat

27−

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

39−import 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

53−

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

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

56−--

57−-- prop> validateToJSON (x :: Int) == []

58−--

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

60−-- See @'validateToJSONWithPatternChecker'@.

61−--

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

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

64−validatePrettyToJSON = renderValidationErrors validateToJSON

65−

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

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

68−validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

69−

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

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

72−--

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

171− Failed xs -> xs

172− Passed _ -> mempty

173− where

174− cfg = defaultConfig

175− { configPatternChecker = checker

176− , configDefinitions = defs }

177−

178−-- | Validation error message.

179−type ValidationError = String

180−

181−-- | Validation result type.

182−data Result a

183− = Failed [ValidationError] -- ^ Validation failed with a list of error messages.

184− | Passed a -- ^ Validation passed.

185− deriving (Eq, Show, Functor)

186−

187−instance Applicative Result where

188− pure = Passed

189− Passed f <*> Passed x = Passed (f x)

190− Failed xs <*> Failed ys = Failed (xs <> ys)

191− Failed xs <*> _ = Failed xs

192− _ <*> Failed ys = Failed ys

193−

194−instance Alternative Result where

195− empty = Failed mempty

196− Passed x <|> _ = Passed x

197− _ <|> y = y

198−

199−instance Monad Result where

200− return = pure

201− Passed x >>= f = f x

202− Failed xs >>= _ = Failed xs

203−

204−-- | Validation configuration.

205−data Config = Config

206− { -- | Pattern checker for @'_paramSchemaPattern'@ validation.

207− configPatternChecker :: Pattern -> Text -> Bool

208− -- | Schema definitions in scope to resolve references.

209− , configDefinitions :: Definitions Schema

210− }

211−

212−-- | Default @'Config'@:

213−--

214−-- @

215−-- defaultConfig = 'Config'

216−-- { 'configPatternChecker' = \\_pattern _str -> True

217−-- , 'configDefinitions' = mempty

218−-- }

219−-- @

220−defaultConfig :: Config

221−defaultConfig = Config

222− { configPatternChecker = \_pattern _str -> True

223− , configDefinitions = mempty

224− }

225−

226−-- | Value validation.

227−newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }

228− deriving (Functor)

229−

230−instance Applicative (Validation schema) where

231− pure x = Validation (\_ _ -> pure x)

232− Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)

233−

234−instance Alternative (Validation schema) where

235− empty = Validation (\_ _ -> empty)

236− Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)

237−

238−instance Profunctor Validation where

239− dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))

240−

241−instance Choice Validation where

242− left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))

243− right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))

244−

245−instance Monad (Validation s) where

246− return = pure

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

248− (>>) = (*>)

249−

250−withConfig :: (Config -> Validation s a) -> Validation s a

251−withConfig f = Validation (\c -> runValidation (f c) c)

252−

253−withSchema :: (s -> Validation s a) -> Validation s a

254−withSchema f = Validation (\c s -> runValidation (f s) c s)

255−

256−-- | Issue an error message.

257−invalid :: String -> Validation schema a

258−invalid msg = Validation (\_ _ -> Failed [msg])

259−

260−-- | Validation passed.

261−valid :: Validation schema ()

262−valid = pure ()

263−

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

265−-- 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.

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

276−check = checkMissing valid

277−

278−-- | Validate same value with different schema.

279−sub :: t -> Validation t a -> Validation s a

280−sub = lmap . const

281−

282−-- | Validate same value with a part of the original schema.

283−sub_ :: Getting a s a -> Validation a r -> Validation s r

284−sub_ = lmap . view

285−

286−-- | Validate value against a schema given schema reference and validation function.

287−withRef :: Reference -> (Schema -> Validation s a) -> Validation s a

288−withRef (Reference ref) f = withConfig $ \cfg ->

289− case InsOrdHashMap.lookup ref (configDefinitions cfg) of

290− Nothing -> invalid $ "unknown schema " ++ show ref

291− Just s -> f s

292−

293−validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

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

295−validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

296−

297−-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

298−validateWithSchema :: Value -> Validation Schema ()

299−validateWithSchema value = do

300− validateSchemaType value

301− sub_ paramSchema $ validateEnum value

302−

303−-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.

304−validateWithParamSchema :: Value -> Validation (ParamSchema t) ()

305−validateWithParamSchema value = do

306− validateParamSchemaType value

307− validateEnum value

308−

309−validateInteger :: Scientific -> Validation (ParamSchema t) ()

310−validateInteger n = do

311− when (not (isInteger n)) $

312− invalid ("not an integer")

313− validateNumber n

314−

315−validateNumber :: 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

319−

320− check maximum_ $ \m ->

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

322− invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")

323−

324− check minimum_ $ \m ->

325− when (if exMin then (n <= m) else (n < m)) $

326− invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")

327−

328− check multipleOf $ \k ->

329− when (not (isInteger (n / k))) $

330− invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)

331−

332−validateString :: Text -> Validation (ParamSchema t) ()

333−validateString s = do

334− check maxLength $ \n ->

335− when (len > fromInteger n) $

336− invalid ("string is too long (length should be <=" ++ show n ++ ")")

337−

338− check minLength $ \n ->

339− when (len < fromInteger n) $

340− invalid ("string is too short (length should be >=" ++ show n ++ ")")

341−

342− check pattern $ \regex -> do

343− withConfig $ \cfg -> do

344− when (not (configPatternChecker cfg regex s)) $

345− invalid ("string does not match pattern " ++ show regex)

346− where

347− len = Text.length s

348−

349−validateArray :: Vector Value -> Validation (ParamSchema t) ()

350−validateArray xs = do

351− check maxItems $ \n ->

352− when (len > fromInteger n) $

353− invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")

354−

355− check minItems $ \n ->

356− when (len < fromInteger n) $

357− invalid ("array is too short (size should be >=" ++ show n ++ ")")

358−

359− check items $ \case

360− SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs

361− SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs

362− SwaggerItemsArray itemSchemas -> do

363− when (len /= length itemSchemas) $

364− invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")

365− sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))

366−

367− check uniqueItems $ \unique ->

368− when (unique && not allUnique) $

369− invalid ("array is expected to contain unique items, but it does not")

370− where

371− len = Vector.length xs

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

373−

374−validateObject :: HashMap Text Value -> Validation Schema ()

375−validateObject o = withSchema $ \sch ->

376− case sch ^. discriminator of

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

378− Just (Success ref) -> validateWithSchemaRef ref (Object o)

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

380− Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")

381− Nothing -> do

382− check maxProperties $ \n ->

383− when (size > n) $

384− invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")

385−

386− check minProperties $ \n ->

387− when (size < n) $

388− invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")

389−

390− validateRequired

391− validateProps

392− where

393− size = fromIntegral (HashMap.size o)

394−

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

399−

400− validateProps = withSchema $ \sch -> do

401− for_ (HashMap.toList o) $ \(k, v) ->

402− case v of

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

404− _ ->

405− case InsOrdHashMap.lookup k (sch ^. properties) of

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

407− Just s -> validateWithSchemaRef s v

408−

409− validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid

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

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

412−

413− unknownProperty :: Text -> Validation s a

414− unknownProperty pname = invalid $

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

416−

417−validateEnum :: Value -> Validation (ParamSchema t) ()

418−validateEnum value = do

419− check enum_ $ \xs ->

420− when (value `notElem` xs) $

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

422−

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

424−--

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

426−--

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

428−-- Just [SwaggerObject]

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

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

431− [ SwaggerObject | any ($ sch)

432− [ has (additionalProperties._Just)

433− , has (maxProperties._Just)

434− , has (minProperties._Just)

435− , has (properties.folded)

436− , has (required.folded) ] ]

437−

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

439−--

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

441−-- Just [SwaggerString]

442−--

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

444−-- Just [SwaggerArray]

445−--

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

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

448−--

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

450−-- Just [SwaggerInteger]

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

452−inferParamSchemaTypes sch = concat

453− [ [ SwaggerArray | any ($ sch)

454− [ has (items._Just)

455− , has (maxItems._Just)

456− , has (minItems._Just)

457− , has (uniqueItems._Just) ] ]

458− , [ SwaggerInteger | any ($ sch)

459− [ has (exclusiveMaximum._Just)

460− , has (exclusiveMinimum._Just)

461− , has (maximum_._Just)

462− , has (minimum_._Just)

463− , has (multipleOf._Just) ] ]

464− , [ SwaggerString | any ($ sch)

465− [ has (maxLength._Just)

466− , has (minLength._Just)

467− , has (pattern._Just) ] ]

468− ]

469−

470−validateSchemaType :: 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

488−

489−validateParamSchemaType :: 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"

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+46−9

@@ -9,6 +9,8 @@ module Data.Swagger.Internal.Utils where

99import Prelude ()

1010import Prelude.Compat

1111

12+import Control.Arrow (first)

13+import Control.Applicative

1214import Control.Lens ((&), (%~))

1315import Control.Lens.TH

1416import Data.Aeson

@@ -18,13 +20,12 @@ import Data.Data

1820import Data.Hashable (Hashable)

1921import Data.HashMap.Strict (HashMap)

2022import qualified Data.HashMap.Strict as HashMap

21−import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

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

2323import Data.Map (Map)

24−import Data.Set (Set)

24+import Data.Monoid

2525import Data.Text (Text)

2626import GHC.Generics

2727import Language.Haskell.TH (mkName)

28+import Text.Read (readMaybe)

2829

2930swaggerFieldRules :: LensRules

3031swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer

@@ -43,7 +44,6 @@ swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer

4344 fixName' "minimum" = "minimum_" -- Prelude conflict

4445 fixName' "maximum" = "maximum_" -- Prelude conflict

4546 fixName' "enum" = "enum_" -- Control.Lens conflict

46− fixName' "head" = "head_" -- Prelude conflict

4747 fixName' n = n

4848

4949gunfoldEnum :: String -> [a] -> (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c a

@@ -51,6 +51,17 @@ gunfoldEnum tname xs _k z c = case lookup (constrIndex c) (zip [1..] xs) of

5151 Just x -> z x

5252 Nothing -> error $ "Data.Data.gunfold: Constructor " ++ show c ++ " is not of type " ++ tname ++ "."

5353

54+hashMapMapKeys :: (Eq k', Hashable k') => (k -> k') -> HashMap k v -> HashMap k' v

55+hashMapMapKeys f = HashMap.fromList . map (first f) . HashMap.toList

56+

57+hashMapTraverseKeys :: (Eq k', Hashable k', Applicative f) => (k -> f k') -> HashMap k v -> f (HashMap k' v)

58+hashMapTraverseKeys f = fmap HashMap.fromList . traverse g . HashMap.toList

59+ where

60+ g (x, y) = (\a -> (a, y)) <$> f x

61+

62+hashMapReadKeys :: (Eq k, Read k, Hashable k, Alternative f) => HashMap String v -> f (HashMap k v)

63+hashMapReadKeys = hashMapTraverseKeys (maybe empty pure . readMaybe)

64+

5465jsonPrefix :: String -> Options

5566jsonPrefix prefix = defaultOptions

5667 { fieldLabelModifier = modifier . drop 1

@@ -72,10 +83,40 @@ parseOneOf xs js =

7283 where

7384 ys = zip (map toJSON xs) xs

7485

86+omitEmptiesExcept :: (Text -> Value -> Bool) -> Value -> Value

87+omitEmptiesExcept f (Object o) = Object (HashMap.filterWithKey nonEmpty o)

88+ where

89+ nonEmpty k js = f k js || (js /= Object mempty) && (js /= Array mempty) && (js /= Null)

90+omitEmptiesExcept _ js = js

91+

92+omitEmpties :: Value -> Value

93+omitEmpties = omitEmptiesExcept (\_ _ -> False)

94+

95+genericToJSONWithSub :: (Generic a, GToJSON (Rep a)) => Text -> Options -> a -> Value

96+genericToJSONWithSub sub opts x =

97+ case genericToJSON opts x of

98+ Object o ->

99+ case HashMap.lookup sub o of

100+ Just so -> Object (HashMap.delete sub o) <+> so

101+ Nothing -> Object o -- no subjson, leaving object as is

102+ _ -> error "genericToJSONWithSub: subjson is not an object"

103+

104+genericParseJSONWithSub :: (Generic a, GFromJSON (Rep a)) => Text -> Options -> Value -> Parser a

105+genericParseJSONWithSub sub opts js@(Object o)

106+ = genericParseJSON opts js -- try without subjson

107+ <|> genericParseJSON opts js' -- try with subjson

108+ where

109+ js' = Object (HashMap.insert sub (Object o) o)

110+genericParseJSONWithSub _ _ _ = error "genericParseJSONWithSub: given json is not an object"

111+

75112(<+>) :: Value -> Value -> Value

76113Object x <+> Object y = Object (x <> y)

77114_ <+> _ = error "<+>: merging non-objects"

78115

116+withDefaults :: (Value -> Parser a) -> [Pair] -> Value -> Parser a

117+withDefaults parser defs js@(Object _) = parser (js <+> object defs)

118+withDefaults _ _ _ = empty

119+

79120genericMempty :: (Generic a, GMonoid (Rep a)) => a

80121genericMempty = to gmempty

81122

@@ -111,17 +152,12 @@ class SwaggerMonoid m where

111152 swaggerMappend = mappend

112153

113154instance SwaggerMonoid [a]

114−instance Ord a => SwaggerMonoid (Set a)

115155instance Ord k => SwaggerMonoid (Map k v)

116156

117157instance (Eq k, Hashable k) => SwaggerMonoid (HashMap k v) where

118158 swaggerMempty = mempty

119159 swaggerMappend = HashMap.unionWith (\_old new -> new)

120160

121−instance (Eq k, Hashable k) => SwaggerMonoid (InsOrdHashMap k v) where

122− swaggerMempty = mempty

123− swaggerMappend = InsOrdHashMap.unionWith (\_old new -> new)

124−

125161instance SwaggerMonoid Text where

126162 swaggerMempty = mempty

127163 swaggerMappend x "" = x

@@ -131,3 +167,4 @@ instance SwaggerMonoid (Maybe a) where

131167 swaggerMempty = Nothing

132168 swaggerMappend x Nothing = x

133169 swaggerMappend _ y = y

170+

src/Data/Swagger/Lens.hs+9−30

@@ -7,16 +7,9 @@

77{-# LANGUAGE RankNTypes #-}

88{-# LANGUAGE TemplateHaskell #-}

99{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE DataKinds #-}

1110{-# LANGUAGE UndecidableInstances #-}

1211{-# OPTIONS_GHC -fno-warn-orphans #-}

1312#include "overlapping-compat.h"

14−-- |

15−-- Module: Data.Swagger.Lens

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

17−-- Stability: experimental

18−--

19−-- Lenses and prisms for Swagger.

2013module Data.Swagger.Lens where

2114

2215import Control.Lens

@@ -33,7 +26,7 @@ makeFields ''Host

3326makeFields ''Info

3427makeFields ''Contact

3528makeFields ''License

36−makeLensesWith swaggerFieldRules ''PathItem

29+makeFields ''PathItem

3730makeFields ''Tag

3831makeFields ''Operation

3932makeFields ''Param

@@ -55,28 +48,22 @@ makeFields ''ExternalDocs

5548makePrisms ''ParamAnySchema

5649-- ** 'SecuritySchemeType' prisms

5750makePrisms ''SecuritySchemeType

58−-- ** 'Referenced' prisms

59−makePrisms ''Referenced

6051

6152-- ** 'SwaggerItems' prisms

6253

63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]

54+_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]

6455_SwaggerItemsArray

65− = unto (\x -> SwaggerItemsArray x)

66−{- \x -> case x of

56+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of

6757 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

6858 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

6959 SwaggerItemsArray a -> Right a

70−-}

7160

72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

61+_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)

7362_SwaggerItemsObject

74− = unto (\x -> SwaggerItemsObject x)

75−{- \x -> case x of

63+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of

7664 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

7765 SwaggerItemsObject o -> Right o

7866 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

79−-}

8067

8168_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

8269_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

@@ -96,19 +83,11 @@ instance At Responses where at n = responses . at n

9683instance Ixed Operation where ix n = responses . ix n

9784instance At Operation where at n = responses . at n

9885

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−

105−instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

106−

10786-- 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_

87+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_

88+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_

89+instance HasType NamedSchema (SwaggerType Schema) where type_ = schema.paramSchema.type_

90+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_

11291

11392-- HasDefault instances

11493instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

src/Data/Swagger/Operation.hsdeleted−193

@@ -1,193 +0,0 @@

1−{-# LANGUAGE RankNTypes #-}

2−-- |

3−-- Module: Data.Swagger.Operation

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

5−-- Stability: experimental

6−--

7−-- Helper traversals and functions for Swagger operations manipulations.

8−-- These might be useful when you already have Swagger specification

9−-- generated by something else.

10−module Data.Swagger.Operation (

11− -- * Operation traversals

12− allOperations,

13− operationsOf,

14−

15− -- * Manipulation

16− -- ** Tags

17− applyTags,

18− applyTagsFor,

19−

20− -- ** Responses

21− setResponse,

22− setResponseWith,

23− setResponseFor,

24− setResponseForWith,

25−

26− -- ** Paths

27− prependPath,

28−

29− -- * Miscellaneous

30− declareResponse,

31−) where

32−

33−import Prelude ()

34−import Prelude.Compat

35−

36−import Control.Lens

37−import Data.Data.Lens

38−import Data.List.Compat

39−import Data.Maybe (mapMaybe)

40−import Data.Proxy

41−import qualified Data.Set as Set

42−

43−import Data.Swagger.Declare

44−import Data.Swagger.Internal

45−import Data.Swagger.Lens

46−import Data.Swagger.Schema

47−

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

49−import qualified Data.HashSet.InsOrd as InsOrdHS

50−

51−-- $setup

52−-- >>> import Data.Aeson

53−-- >>> import Data.Proxy

54−-- >>> import Data.Time

55−

56−-- | Prepend path piece to all operations of the spec.

57−-- Leading and trailing slashes are trimmed/added automatically.

58−--

59−-- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)]

60−-- >>> encode $ prependPath "user/{user_id}" api ^. paths

61−-- "{\"/user/{user_id}/info\":{}}"

62−prependPath :: FilePath -> Swagger -> Swagger

63−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)

64− where

65− x </> y = case trim y of

66− "" -> "/" <> trim x

67− y' -> "/" <> trim x <> "/" <> y'

68−

69− trim = dropWhile (== '/') . dropWhileEnd (== '/')

70−

71−-- | All operations of a Swagger spec.

72−allOperations :: Traversal' Swagger Operation

73−allOperations = paths.traverse.template

74−

75−-- | @'operationsOf' sub@ will traverse only those operations

76−-- that are present in @sub@. Note that @'Operation'@ is determined

77−-- by both path and method.

78−--

79−-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"

80−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]

81−-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

82−-- >>> encode api

83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"

84−-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"

85−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"

86−operationsOf :: Swagger -> Traversal' Swagger Operation

87−operationsOf sub = paths.itraversed.withIndex.subops

88− where

89− -- | Traverse operations that correspond to paths and methods of the sub API.

90− subops :: Traversal' (FilePath, PathItem) Operation

91− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of

92− Just subitem -> (,) path <$> methodsOf subitem f item

93− Nothing -> pure (path, item)

94−

95− -- | Traverse operations that exist in a given @'PathItem'@

96− -- This is used to traverse only the operations that exist in sub API.

97− methodsOf :: PathItem -> Traversal' PathItem Operation

98− methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just

99− where

100− ops = pathItem ^.. template :: [Maybe Operation]

101− ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops

102−

103−-- | Apply tags to all operations and update the global list of tags.

104−--

105−-- @

106−-- 'applyTags' = 'applyTagsFor' 'allOperations'

107−-- @

108−applyTags :: [Tag] -> Swagger -> Swagger

109−applyTags = applyTagsFor allOperations

110−

111−-- | Apply tags to a part of Swagger spec and update the global

112−-- list of tags.

113−applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

114−applyTagsFor ops ts swag = swag

115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))

116− & tags %~ (<> InsOrdHS.fromList ts)

117−

118−-- | Construct a response with @'Schema'@ while declaring all

119−-- necessary schema definitions.

120−--

121−-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

122−-- "[{\"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 proxy = do

125− s <- declareSchemaRef proxy

126− return (mempty & schema ?~ s)

127−

128−-- | Set response for all operations.

129−-- This will also update global schema definitions.

130−--

131−-- If the response already exists it will be overwritten.

132−--

133−-- @

134−-- 'setResponse' = 'setResponseFor' 'allOperations'

135−-- @

136−--

137−-- Example:

138−--

139−-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

140−-- >>> let res = declareResponse (Proxy :: Proxy Day)

141−-- >>> encode $ api & setResponse 200 res

142−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"

143−--

144−-- See also @'setResponseWith'@.

145−setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

146−setResponse = setResponseFor allOperations

147−

148−-- | Set or update response for all operations.

149−-- This will also update global schema definitions.

150−--

151−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),

152−-- then just the new response is used.

153−--

154−-- @

155−-- 'setResponseWith' = 'setResponseForWith' 'allOperations'

156−-- @

157−--

158−-- See also @'setResponse'@.

159−setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

160−setResponseWith = setResponseForWith allOperations

161−

162−-- | Set response for specified operations.

163−-- This will also update global schema definitions.

164−--

165−-- If the response already exists it will be overwritten.

166−--

167−-- See also @'setResponseForWith'@.

168−setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

169−setResponseFor ops code dres swag = swag

170− & definitions %~ (<> defs)

171− & ops . at code ?~ Inline res

172− where

173− (defs, res) = runDeclare dres mempty

174−

175−-- | Set or update response for specified operations.

176−-- This will also update global schema definitions.

177−--

178−-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),

179−-- then just the new response is used.

180−--

181−-- See also @'setResponseFor'@.

182−setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

183−setResponseForWith ops f code dres swag = swag

184− & definitions %~ (<> defs)

185− & ops . at code %~ Just . Inline . combine

186− where

187− (defs, new) = runDeclare dres mempty

188−

189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of

190− Just old -> f old new

191− Nothing -> new -- response name can't be dereferenced, replacing with new response

192− combine (Just (Inline old)) = f old new

193− combine Nothing = new

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/ParamSchema.hs+2−5

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

11-- |

22-- Module: Data.Swagger.ParamSchema

4+-- License: BSD3

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

46-- Stability: experimental

57--

@@ -12,11 +14,6 @@ module Data.Swagger.ParamSchema (

1214 genericToParamSchema,

1315 toParamSchemaBoundedIntegral,

1416

15− -- * Schema templates

16− passwordParamSchema,

17− binaryParamSchema,

18− byteParamSchema,

19−

2017 -- * Generic encoding configuration

2118 SchemaOptions(..),

2219 defaultSchemaOptions,

src/Data/Swagger/Schema.hs+2−24

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

11-- |

22-- Module: Data.Swagger.Schema

4+-- License: BSD3

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

46-- Stability: experimental

57--

@@ -17,34 +19,11 @@ module Data.Swagger.Schema (

1719 -- * Generic schema encoding

1820 genericDeclareNamedSchema,

1921 genericDeclareSchema,

20− genericDeclareNamedSchemaNewtype,

21− genericNameSchema,

22−

23− -- ** 'Bounded' 'Integral'

2422 genericToNamedSchemaBoundedIntegral,

2523 toSchemaBoundedIntegral,

26−

27− -- ** 'Bounded' 'Enum' key mappings

28− declareSchemaBoundedEnumKeyMapping,

29− toSchemaBoundedEnumKeyMapping,

30−

31− -- ** Reusing 'ToParamSchema'

3224 paramSchemaToNamedSchema,

3325 paramSchemaToSchema,

3426

35− -- ** Unrestricted versions

36− genericDeclareNamedSchemaUnrestricted,

37− genericDeclareSchemaUnrestricted,

38−

39− -- * Schema templates

40− passwordSchema,

41− binarySchema,

42− byteSchema,

43−

44− -- * Sketching @'Schema'@s using @'ToJSON'@

45− sketchSchema,

46− sketchStrictSchema,

47−

4827 -- * Inlining @'Schema'@s

4928 inlineNonRecursiveSchemas,

5029 inlineAllSchemas,

@@ -54,7 +33,6 @@ module Data.Swagger.Schema (

5433 -- * Generic encoding configuration

5534 SchemaOptions(..),

5635 defaultSchemaOptions,

57− fromAesonOptions,

5836) where

5937

6038import 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+308−74

@@ -1,90 +1,324 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE PackageImports #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TemplateHaskell #-}

12+{-# LANGUAGE UndecidableInstances #-}

113-- |

2−-- Module: Data.Swagger.Schema.Validation

14+-- Module: Data.Swagger.Schema.Validate

16+-- License: BSD3

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

418-- Stability: experimental

519--

620-- Validate JSON values with Swagger Schema.

7−module Data.Swagger.Schema.Validation (

8− -- * How to use validation

9− -- $howto

21+module Data.Swagger.Schema.Validation where

1022

11− -- ** Examples

12− -- $examples

23+import Control.Applicative

24+import Control.Lens

25+import Control.Lens.TH

26+import Control.Monad (when)

1327

14− -- ** Validating @'Maybe'@

15− -- $maybe

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

32+import qualified "unordered-containers" Data.HashSet as HashSet

33+import Data.Monoid

34+import Data.Proxy

35+import Data.Scientific (Scientific, isInteger)

36+import Data.Text (Text)

37+import qualified Data.Text as Text

38+import Data.Vector (Vector)

39+import qualified Data.Vector as Vector

1640

17− -- * JSON validation

41+import Data.Swagger.Declare

42+import Data.Swagger.Internal

43+import Data.Swagger.Internal.Schema

44+import Data.Swagger.Lens

1845

19− ValidationError,

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

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

48+--

49+-- prop> validateToJSON (x :: Int) == []

50+--

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

52+-- See @'validateToJSONWithPatternChecker'@.

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

54+validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

2055

21− -- ** Using 'ToJSON' and 'ToSchema'

22− validatePrettyToJSON,

23− validateToJSON,

24− validateToJSONWithPatternChecker,

25− renderValidationErrors,

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

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

58+--

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

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

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

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

63+ Failed xs -> xs

64+ Passed _ -> mempty

65+ where

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

67+ js = toJSON x

68+ cfg = defaultConfig

69+ { configPatternChecker = checker

70+ , configDefinitions = defs }

2671

27− -- ** Using 'Value' and 'Schema'

28− validateJSON,

29− validateJSONWithPatternChecker,

30−) where

72+-- | Validation error message.

73+type ValidationError = String

3174

32−import Data.Swagger.Internal.Schema.Validation

75+-- | Validation result type.

76+data Result a

77+ = Failed [ValidationError] -- ^ Validation failed with a list of error messages.

78+ | Passed a -- ^ Validation passed.

79+ deriving (Eq, Show, Functor)

3380

34−-- $setup

35−-- >>> import Control.Lens

36−-- >>> import Data.Aeson

37−-- >>> import Data.Proxy

38−-- >>> import Data.Swagger

39−-- >>> import GHC.Generics

40−-- >>> :set -XDeriveGeneric

81+instance Applicative Result where

82+ pure = Passed

83+ Passed f <*> Passed x = Passed (f x)

84+ Failed xs <*> Failed ys = Failed (xs <> ys)

85+ Failed xs <*> _ = Failed xs

86+ _ <*> Failed ys = Failed ys

4187

42−-- $howto

43−--

44−-- This module provides helpful functions for JSON validation.

45−-- These functions are meant to be used in test suites for your application

46−-- to ensure that JSON respresentation for your data corresponds to

47−-- schemas you're using for the Swagger specification.

48−--

49−-- It is recommended to use validation functions as QuickCheck properties

50−-- (see <http://hackage.haskell.org/package/QuickCheck>).

88+instance Alternative Result where

89+ empty = Failed mempty

90+ Passed x <|> _ = Passed x

91+ _ <|> y = y

5192

52−-- $examples

53−--

54−-- >>> validateToJSON "hello"

55−-- []

56−--

57−-- >>> validateToJSON False

58−-- []

59−--

60−-- >>> newtype Nat = Nat Integer deriving Generic

61−-- >>> instance ToJSON Nat where toJSON (Nat n) = toJSON n

62−-- >>> instance ToSchema Nat where declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy & mapped.minimum_ ?~ 0

63−-- >>> validateToJSON (Nat 10)

64−-- []

65−-- >>> validateToJSON (Nat (-5))

66−-- ["value -5.0 falls below minimum (should be >=0.0)"]

67−

68−-- $maybe

69−--

70−-- Because @'Maybe' a@ has the same schema as @a@, validation

71−-- generally fails for @null@ JSON:

72−--

73−-- >>> validateToJSON (Nothing :: Maybe String)

74−-- ["expected JSON value of type SwaggerString"]

75−-- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])

76−-- ["expected JSON value of type SwaggerString"]

77−-- >>> validateToJSON (123, Nothing :: Maybe String)

78−-- ["expected JSON value of type SwaggerString"]

79−--

80−-- However, when @'Maybe' a@ is a type of a record field,

81−-- validation takes @'required'@ property of the @'Schema'@

82−-- into account:

93+instance Monad Result where

94+ return = pure

95+ Passed x >>= f = f x

96+ Failed xs >>= f = Failed xs

97+

98+-- | Validation configuration.

99+data Config = Config

100+ { -- | Pattern checker for @'_paramSchemaPattern'@ validation.

101+ configPatternChecker :: Pattern -> Text -> Bool

102+ -- | Schema definitions in scope to resolve references.

103+ , configDefinitions :: Definitions Schema

104+ }

105+

106+-- | Default @'Config'@:

83107--

84−-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic

85−-- >>> instance ToJSON Person

86−-- >>> instance ToSchema Person

87−-- >>> validateToJSON (Person "Nick" (Just 24))

88−-- []

89−-- >>> validateToJSON (Person "Nick" Nothing)

90−-- []

108+-- @

109+-- defaultConfig = 'Config'

110+-- { 'configPatternChecker' = \\_pattern _str -> True

111+-- , 'configDefinitions' = mempty

112+-- }

113+-- @

114+defaultConfig :: Config

115+defaultConfig = Config

116+ { configPatternChecker = \_pattern _str -> True

117+ , configDefinitions = mempty

118+ }

119+

120+-- | Value validation.

121+newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }

122+ deriving (Functor)

123+

124+instance Applicative (Validation schema) where

125+ pure x = Validation (\_ _ -> pure x)

126+ Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)

127+

128+instance Alternative (Validation schema) where

129+ empty = Validation (\_ _ -> empty)

130+ Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)

131+

132+instance Profunctor Validation where

133+ dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))

134+

135+instance Choice Validation where

136+ left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))

137+ right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))

138+

139+instance Monad (Validation s) where

140+ return = pure

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

142+ (>>) = (*>)

143+

144+withConfig :: (Config -> Validation s a) -> Validation s a

145+withConfig f = Validation (\c -> runValidation (f c) c)

146+

147+withSchema :: (s -> Validation s a) -> Validation s a

148+withSchema f = Validation (\c s -> runValidation (f s) c s)

149+

150+-- | Issue an error message.

151+invalid :: String -> Validation schema a

152+invalid msg = Validation (\_ _ -> Failed [msg])

153+

154+-- | Validation passed.

155+valid :: Validation schema ()

156+valid = pure ()

157+

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

159+-- and property checker.

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

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

162+ case schema ^. l of

163+ Nothing -> valid

164+ Just x -> g x

165+

166+-- | Validate same value with different schema.

167+sub :: t -> Validation t a -> Validation s a

168+sub = lmap . const

169+

170+-- | Validate same value with a part of the original schema.

171+sub_ :: Getting a s a -> Validation a r -> Validation s r

172+sub_ = lmap . view

173+

174+-- | Validate value against a schema given schema reference and validation function.

175+withRef :: Reference -> (Schema -> Validation s a) -> Validation s a

176+withRef (Reference ref) f = withConfig $ \cfg ->

177+ case HashMap.lookup ref (configDefinitions cfg) of

178+ Nothing -> invalid $ "unknown schema " ++ show ref

179+ Just s -> f s

180+

181+validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

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

183+validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

184+

185+-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

186+validateWithSchema :: Value -> Validation Schema ()

187+validateWithSchema value = do

188+ validateSchemaType value

189+ sub_ paramSchema $ validateEnum value

190+

191+-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.

192+validateWithParamSchema :: Value -> Validation (ParamSchema t) ()

193+validateWithParamSchema value = do

194+ validateParamSchemaType value

195+ validateEnum value

196+

197+validateInteger :: Scientific -> Validation (ParamSchema t) ()

198+validateInteger n = do

199+ when (not (isInteger n)) $

200+ invalid ("not an integer")

201+ validateNumber n

202+

203+validateNumber :: Scientific -> Validation (ParamSchema t) ()

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

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

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

207+

208+ check maximum_ $ \m ->

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

210+ invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")

211+

212+ check minimum_ $ \m ->

213+ when (if exMin then (n <= m) else (n < m)) $

214+ invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")

215+

216+ check multipleOf $ \k ->

217+ when (not (isInteger (n / k))) $

218+ invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)

219+

220+validateString :: Text -> Validation (ParamSchema t) ()

221+validateString s = do

222+ check maxLength $ \n ->

223+ when (len > fromInteger n) $

224+ invalid ("string is too long (length should be <=" ++ show n ++ ")")

225+

226+ check minLength $ \n ->

227+ when (len < fromInteger n) $

228+ invalid ("string is too short (length should be >=" ++ show n ++ ")")

229+

230+ check pattern $ \regex -> do

231+ withConfig $ \cfg -> do

232+ when (not (configPatternChecker cfg regex s)) $

233+ invalid ("string does not match pattern " ++ show regex)

234+ where

235+ len = Text.length s

236+

237+validateArray :: Vector Value -> Validation (ParamSchema t) ()

238+validateArray xs = do

239+ check maxItems $ \n ->

240+ when (len > fromInteger n) $

241+ invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")

242+

243+ check minItems $ \n ->

244+ when (len < fromInteger n) $

245+ invalid ("array is too short (size should be >=" ++ show n ++ ")")

246+

247+ check items $ \case

248+ SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs

249+ SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs

250+ SwaggerItemsArray itemSchemas -> do

251+ when (len /= length itemSchemas) $

252+ invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")

253+ sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))

254+

255+ check uniqueItems $ \unique ->

256+ when (unique && not allUnique) $

257+ invalid ("array is expected to contain unique items, but it does not")

258+ where

259+ len = Vector.length xs

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

261+

262+validateObject :: HashMap Text Value -> Validation Schema ()

263+validateObject o = withSchema $ \schema ->

264+ case schema ^. discriminator of

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

266+ Just (Success ref) -> validateWithSchemaRef ref (Object o)

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

268+ Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")

269+ Nothing -> do

270+ check maxProperties $ \n ->

271+ when (size > n) $

272+ invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")

273+

274+ check minProperties $ \n ->

275+ when (size < n) $

276+ invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")

277+

278+ validateRequired

279+ validateProps

280+ where

281+ size = fromIntegral (HashMap.size o)

282+

283+ validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)

284+ validateReq name =

285+ when (not (HashMap.member name o)) $

286+ invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))

287+

288+ validateProps = withSchema $ \schema -> do

289+ for_ (HashMap.toList o) $ \(k, v) ->

290+ case v of

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

292+ _ ->

293+ case HashMap.lookup k (schema ^. properties) of

294+ Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v

295+ Just s -> validateWithSchemaRef s v

296+

297+validateEnum :: Value -> Validation (ParamSchema t) ()

298+validateEnum value = do

299+ check enum_ $ \xs ->

300+ when (value `notElem` xs) $

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

302+

303+validateSchemaType :: Value -> Validation Schema ()

304+validateSchemaType value = withSchema $ \schema ->

305+ case (schema ^. type_, value) of

306+ (SwaggerNull, Null) -> valid

307+ (SwaggerBoolean, Bool _) -> valid

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

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

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

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

312+ (SwaggerObject, Object o) -> validateObject o

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

314+

315+validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

316+validateParamSchemaType value = withSchema $ \schema ->

317+ case (schema ^. type_, value) of

318+ (SwaggerBoolean, Bool _) -> valid

319+ (SwaggerInteger, Number n) -> validateInteger n

320+ (SwaggerNumber, Number n) -> validateNumber n

321+ (SwaggerString, String s) -> validateString s

322+ (SwaggerArray, Array xs) -> validateArray xs

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

324+

src/Data/Swagger/SchemaOptions.hs−35

@@ -1,14 +1,5 @@

1−{-# LANGUAGE RecordWildCards #-}

2−-- |

3−-- Module: Data.Swagger.SchemaOptions

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

5−-- Stability: experimental

6−--

7−-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.

81module Data.Swagger.SchemaOptions where

10−import qualified Data.Aeson.Types as Aeson

11−

123-- | Options that specify how to encode your type to Swagger schema.

134data SchemaOptions = SchemaOptions

145 { -- | Function applied to field labels. Handy for removing common record prefixes for example.

@@ -44,29 +35,3 @@ defaultSchemaOptions = SchemaOptions

4435 , unwrapUnaryRecords = False

4536 }

4637

47−-- | Convert 'Aeson.Options' to 'SchemaOptions'.

48−--

49−-- Specifically the following fields get copied:

50−--

51−-- * 'fieldLabelModifier'

52−-- * 'constructorTagModifier'

53−-- * 'allNullaryToStringTag'

54−-- * 'unwrapUnaryRecords'

55−--

56−-- Note that these fields have no effect on `SchemaOptions`:

57−--

58−-- * 'Aeson.omitNothingFields'

59−-- * 'Aeson.sumEncoding'

60−-- * 'Aeson.tagSingleConstructors'

61−--

62−-- The rest is defined as in 'defaultSchemaOptions'.

63−--

64−-- @since 2.2.1

65−--

66−fromAesonOptions :: Aeson.Options -> SchemaOptions

67−fromAesonOptions opts = defaultSchemaOptions

68− { fieldLabelModifier = Aeson.fieldLabelModifier opts

69− , constructorTagModifier = Aeson.constructorTagModifier opts

70− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts

71− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts

72− }

stack-lts-2.yamlnew file+5

@@ -0,0 +1,5 @@

1+flags: {}

2+packages:

3+- '.'

4+extra-deps: []

5+resolver: lts-2.22

stack.yaml+3−7

@@ -1,9 +1,5 @@

1−resolver: lts-14.3

1+flags: {}

22packages:

33- '.'

4−extra-deps:

5−- optics-core-0.2

6−- optics-th-0.2

7−- optics-extra-0.2

8−- indexed-profunctors-0.1

9−- insert-ordered-containers-0.2.3

4+extra-deps: []

5+resolver: nightly-2016-01-26

swagger2.cabal+42−103

@@ -1,38 +1,23 @@

1−cabal-version: >=1.10

21name: swagger2

3−version: 2.5

4−

2+version: 1.2.1

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

168license-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

3621

3722library

3823 hs-source-dirs: src

@@ -41,112 +26,66 @@ library

4126 Data.Swagger

4227 Data.Swagger.Declare

4328 Data.Swagger.Lens

44− Data.Swagger.Operation

45− Data.Swagger.Optics

4629 Data.Swagger.ParamSchema

4730 Data.Swagger.Schema

48− Data.Swagger.Schema.Generator

4931 Data.Swagger.Schema.Validation

5032 Data.Swagger.SchemaOptions

5133

5234 -- internal modules

5335 Data.Swagger.Internal

5436 Data.Swagger.Internal.Schema

55− Data.Swagger.Internal.Schema.Validation

5637 Data.Swagger.Internal.ParamSchema

5738 Data.Swagger.Internal.Utils

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

39+ build-depends: base >=4.7 && <4.10

40+ , base-compat >=0.6.0 && <0.10

41+ , aeson

42+ , containers

43+ , hashable

44+ , http-media

45+ , lens

46+ , mtl

47+ , network

48+ , scientific

49+ , text

50+ , template-haskell

51+ , time

52+ , transformers

53+ , unordered-containers

54+ , vector

9655 default-language: Haskell2010

9756

9857test-suite spec

9958 type: exitcode-stdio-1.0

10059 hs-source-dirs: test

10160 main-is: Spec.hs

102−

103− -- From library parat

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

61+ build-depends: base

62+ , base-compat

63+ , aeson

64+ , aeson-qq

65+ , containers

66+ , hashable

67+ , hspec

68+ , HUnit

69+ , mtl

70+ , QuickCheck

71+ , swagger2

72+ , text

73+ , time

74+ , unordered-containers

75+ , vector

76+ , lens

13477 other-modules:

13578 SpecCommon

13679 Data.SwaggerSpec

137− Data.Swagger.CommonTestTypes

138− Data.Swagger.ParamSchemaSpec

13980 Data.Swagger.SchemaSpec

14081 Data.Swagger.Schema.ValidationSpec

141− Data.Swagger.Schema.GeneratorSpec

14282 default-language: Haskell2010

14383

144−test-suite doctests

145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes

146− build-depends: base, doctest, Glob, QuickCheck

84+test-suite doctest

85+ build-depends: base, doctest, Glob

14786 default-language: Haskell2010

14887 hs-source-dirs: test

149− main-is: doctests.hs

88+ main-is: DocTest.hs

15089 type: exitcode-stdio-1.0

15190

15291source-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−10

@@ -1,29 +1,22 @@

11{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE ScopedTypeVariables #-}

43{-# LANGUAGE TemplateHaskell #-}

54{-# LANGUAGE QuasiQuotes #-}

6−{-# LANGUAGE OverloadedStrings #-}

75module Data.Swagger.ParamSchemaSpec where

97import Data.Aeson

10−import Data.Aeson.QQ.Simple

8+import Data.Aeson.QQ

119import Data.Char

1210import Data.Proxy

1311import GHC.Generics

1412

1513import Data.Swagger

16−import Data.Swagger.Internal (SwaggerKind(..))

1714

18−import Data.Swagger.CommonTestTypes

1915import SpecCommon

2016import Test.Hspec

21−import Data.Time.LocalTime

22−

23−import qualified Data.HashMap.Strict as HM

2417

2518checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

19+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema Param) <=> js

2720

2821spec :: Spec

2922spec = do

@@ -34,7 +27,88 @@ spec = do

3427 context "Unary records" $ do

3528 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

3629 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

3830

3931main :: IO ()

4032main = hspec spec

33+

34+-- ========================================================================

35+-- Unit type

36+-- ========================================================================

37+

38+data Unit = Unit deriving (Generic)

39+instance ToParamSchema Unit

40+

41+unitSchemaJSON :: Value

42+unitSchemaJSON = [aesonQQ|

43+{

44+ "type": "string",

45+ "enum": ["Unit"]

46+}

47+|]

48+

49+-- ========================================================================

50+-- Color (enum)

51+-- ========================================================================

52+data Color

53+ = Red

54+ | Green

55+ | Blue

56+ deriving (Generic)

57+instance ToParamSchema Color

58+

59+colorSchemaJSON :: Value

60+colorSchemaJSON = [aesonQQ|

61+{

62+ "type": "string",

63+ "enum": ["Red", "Green", "Blue"]

64+}

65+|]

66+

67+-- ========================================================================

68+-- Status (constructorTagModifier)

69+-- ========================================================================

70+

71+data Status = StatusOk | StatusError deriving (Generic)

72+

73+instance ToParamSchema Status where

74+ toParamSchema = genericToParamSchema defaultSchemaOptions

75+ { constructorTagModifier = map toLower . drop (length "Status") }

76+

77+statusSchemaJSON :: Value

78+statusSchemaJSON = [aesonQQ|

79+{

80+ "type": "string",

81+ "enum": ["ok", "error"]

82+}

83+|]

84+

85+-- ========================================================================

86+-- Email (newtype with unwrapUnaryRecords set to True)

87+-- ========================================================================

88+

89+newtype Email = Email { getEmail :: String }

90+ deriving (Generic)

91+instance ToParamSchema Email

92+

93+emailSchemaJSON :: Value

94+emailSchemaJSON = [aesonQQ|

95+{

96+ "type": "string"

97+}

98+|]

99+

100+-- ========================================================================

101+-- UserId (non-record newtype)

102+-- ========================================================================

103+

104+newtype UserId = UserId Integer

105+ deriving (Generic)

106+instance ToParamSchema UserId

107+

108+userIdSchemaJSON :: Value

109+userIdSchemaJSON = [aesonQQ|

110+{

111+ "type": "integer"

112+}

113+|]

114+

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+70−151

@@ -1,50 +1,44 @@

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 DeriveAnyClass #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE PackageImports #-}

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

7+import Control.Applicative

8+import Data.Aeson

9+import Data.Aeson.Types

10+import Data.Int

11+import Data.IntMap (IntMap)

12+import qualified Data.IntMap as IntMap

13+import Data.IntSet (IntSet)

14+import Data.Hashable (Hashable)

15+import "unordered-containers" Data.HashSet (HashSet)

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

18−import Data.Int

19−import Data.IntMap (IntMap)

20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

21−import Data.Map (Map, fromList)

22−import Data.Monoid (mempty)

23−import Data.Proxy

24−import Data.Set (Set)

25−import qualified Data.Text as T

26−import qualified Data.Text.Lazy as TL

27−import Data.Time

28−import Data.Version (Version)

29−import Data.Word

30−import GHC.Generics

31−

32−import Data.Swagger

33−import Data.Swagger.Declare

34−

35−import Test.Hspec

36−import Test.Hspec.QuickCheck

37−import Test.QuickCheck

38−import Test.QuickCheck.Instances ()

17+import Data.HashMap.Strict (HashMap)

18+import qualified Data.HashMap.Strict as HashMap

19+import Data.Map (Map)

20+import qualified Data.Map as Map

21+import Data.Proxy

22+import Data.Time

23+import qualified Data.Text as T

24+import qualified Data.Text.Lazy as TL

25+import Data.Set (Set)

26+import qualified Data.Set as Set

27+import Data.Word

28+import GHC.Generics

29+

30+import Data.Swagger

31+import Data.Swagger.Declare

32+import Data.Swagger.Schema.Validation

33+

34+import SpecCommon

35+import Test.Hspec

36+import Test.Hspec.QuickCheck

37+import Test.QuickCheck

3938

4039shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

4140shouldValidate _ x = validateToJSON x == []

4241

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−

4842spec :: Spec

4943spec = do

5044 describe "Validation" $ do

@@ -73,7 +67,6 @@ spec = do

7367 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

7468 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

7569 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

7770 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

7871 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

7972 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

@@ -83,7 +76,6 @@ spec = do

8376 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

8477 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

8578 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)

8779 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

8880 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

8981 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

@@ -92,16 +84,6 @@ spec = do

9284 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

9385 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

9486 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

10587

10688main :: IO ()

10789main = hspec spec

@@ -109,57 +91,29 @@ main = hspec spec

10991-- ========================================================================

11092-- Person (simple record with optional fields)

11193-- ========================================================================

112−data Person = Person

113− { name :: String

114− , phone :: Integer

115− , email :: Maybe String

116− } deriving (Show, Generic)

117−

118−instance ToJSON Person

119−instance ToSchema Person

94+data Person = Person { name :: String , phone :: Integer , email :: Maybe String } deriving (Show, Generic, ToSchema, ToJSON)

12095

12196instance Arbitrary Person where

12297 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

12398

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−

13199-- ========================================================================

132100-- Color (enum)

133101-- ========================================================================

134−data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)

135−

136−instance ToJSON Color

137−instance ToSchema Color

102+data Color = Red | Green | Blue deriving (Show, Generic, ToSchema, ToJSON, Bounded, Enum)

138103

139104instance Arbitrary Color where

140105 arbitrary = arbitraryBoundedEnum

141106

142−invalidColorToJSON :: Color -> Value

143−invalidColorToJSON Red = toJSON "red"

144−invalidColorToJSON Green = toJSON "green"

145−invalidColorToJSON Blue = toJSON "blue"

146−

147107-- ========================================================================

148108-- Paint (record with bounded enum property)

149109-- ========================================================================

150110

151111newtype Paint = Paint { color :: Color }

152− deriving (Show, Generic)

153−

154−instance ToJSON Paint

155−instance ToSchema Paint

112+ deriving (Show, Generic, ToSchema, ToJSON)

156113

157114instance Arbitrary Paint where

158115 arbitrary = Paint <$> arbitrary

159116

160−invalidPaintToJSON :: Paint -> Value

161−invalidPaintToJSON = toJSON . color

162−

163117-- ========================================================================

164118-- MyRoseTree (custom datatypeNameModifier)

165119-- ========================================================================

@@ -167,9 +121,7 @@ invalidPaintToJSON = toJSON . color

167121data MyRoseTree = MyRoseTree

168122 { root :: String

169123 , trees :: [MyRoseTree]

170− } deriving (Show, Generic)

171−

172−instance ToJSON MyRoseTree

124+ } deriving (Show, Generic, ToJSON)

173125

174126instance ToSchema MyRoseTree where

175127 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

@@ -186,10 +138,7 @@ instance Arbitrary MyRoseTree where

186138-- Light (sum type)

187139-- ========================================================================

188140

189−data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)

190−

191−instance ToSchema Light where

192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

141+data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic, ToSchema)

193142

194143instance ToJSON Light where

195144 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

@@ -201,78 +150,48 @@ instance Arbitrary Light where

201150 , LightColor <$> arbitrary

202151 ]

203152

204−invalidLightToJSON :: Light -> Value

205−invalidLightToJSON = genericToJSON defaultOptions

153+-- Arbitrary instances for common types

206154

207−-- ========================================================================

208−-- ButtonImages (bounded enum key mapping)

209−-- ========================================================================

155+#if MIN_VERSION_QuickCheck(2,8,2)

156+#else

157+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where

158+ arbitrary = Map.fromList <$> arbitrary

210159

211−data ButtonState = Neutral | Focus | Active | Hover | Disabled

212− deriving (Show, Eq, Ord, Bounded, Enum, Generic)

160+instance Arbitrary a => Arbitrary (IntMap a) where

161+ arbitrary = IntMap.fromList <$> arbitrary

213162

214−instance ToJSON ButtonState

215−instance ToSchema ButtonState

216−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

163+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where

164+ arbitrary = Set.fromList <$> arbitrary

165+#endif

217166

218−instance Arbitrary ButtonState where

219− arbitrary = arbitraryBoundedEnum

167+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

168+ arbitrary = HashMap.fromList <$> arbitrary

220169

221−type ImageUrl = T.Text

170+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where

171+ arbitrary = HashSet.fromList <$> arbitrary

222172

223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

224− deriving (Show, Generic)

173+instance Arbitrary T.Text where

174+ arbitrary = T.pack <$> arbitrary

225175

226−instance ToJSON ButtonImages where

227− toJSON = toJSON . getButtonImages

176+instance Arbitrary TL.Text where

177+ arbitrary = TL.pack <$> arbitrary

228178

229−instance ToSchema ButtonImages where

230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

231− declareSchemaBoundedEnumKeyMapping

179+instance Arbitrary Day where

180+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary

232181

233−invalidButtonImagesToJSON :: ButtonImages -> Value

234−invalidButtonImagesToJSON = genericToJSON defaultOptions

235−

236−instance Arbitrary ButtonImages where

237− arbitrary = ButtonImages <$> arbitrary

238−

239−-- ========================================================================

240−-- FreeForm (wraps a raw JSON Value)

241−-- ========================================================================

242−

243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }

244− deriving (Show, Generic)

245−

246−instance ToJSON FreeForm where

247− toJSON = toJSON . jsonContent

248−

249−instance ToSchema FreeForm where

250− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty

251− & type_ ?~ SwaggerObject

252− & additionalProperties ?~ AdditionalPropertiesAllowed True

253−

254−instance Arbitrary FreeForm where

255− arbitrary = (FreeForm . fromList) <$> genObj

256− where

257− genObj = listOf $ do

258− k <- arbitrary

259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]

260− pure (k, v)

182+instance Arbitrary LocalTime where

183+ arbitrary = LocalTime

184+ <$> arbitrary

185+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))

261186

262187instance Eq ZonedTime where

263188 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

264189

265−-- ========================================================================

266−-- Arbitrary instance for Data.Aeson.Value

267−-- ========================================================================

190+instance Arbitrary ZonedTime where

191+ arbitrary = ZonedTime

192+ <$> arbitrary

193+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))

194+

195+instance Arbitrary UTCTime where

196+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))

268197

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+513−25

@@ -7,23 +7,22 @@ module Data.Swagger.SchemaSpec where

77import Prelude ()

88import Prelude.Compat

10−import Control.Lens ((^.))

11−import Data.Aeson (Value)

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

10+import Data.Aeson

11+import Data.Aeson.QQ

12+import Data.Char

13+import qualified Data.HashMap.Strict as HashMap

1314import Data.Proxy

1415import Data.Set (Set)

16+import qualified Data.Set as Set

1517import qualified Data.Text as Text

18+import GHC.Generics

1619

1720import Data.Swagger

1821import Data.Swagger.Declare

1922

20−import Data.Swagger.CommonTestTypes

2123import SpecCommon

2224import Test.Hspec

2325

24−import qualified Data.HashMap.Strict as HM

25−import Data.Time.LocalTime

26−

2726checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

2827checkToSchema proxy js = toSchema proxy <=> js

2928

@@ -35,17 +34,10 @@ checkSchemaName sname proxy =

3534checkDefs :: ToSchema a => Proxy a -> [String] -> Spec

3635checkDefs proxy names =

3736 it ("uses these definitions " ++ show names) $

38− InsOrdHashMap.keys defs `shouldBe` map Text.pack names

37+ Set.fromList (HashMap.keys defs) `shouldBe` Set.fromList (map Text.pack names)

3938 where

4039 defs = execDeclare (declareNamedSchema proxy) mempty

4140

42−checkProperties :: ToSchema a => Proxy a -> [String] -> Spec

43−checkProperties proxy names =

44− it ("has these fields in order " ++ show names) $

45− InsOrdHashMap.keys fields `shouldBe` map Text.pack names

46− where

47− fields = toSchema proxy ^. properties

48−

4941checkInlinedSchema :: ToSchema a => Proxy a -> Value -> Spec

5042checkInlinedSchema proxy js = toInlinedSchema proxy <=> js

5143

@@ -66,9 +58,6 @@ spec = do

6658 context "Person" $ checkToSchema (Proxy :: Proxy Person) personSchemaJSON

6759 context "ISPair" $ checkToSchema (Proxy :: Proxy ISPair) ispairSchemaJSON

6860 context "Point (fieldLabelModifier)" $ checkToSchema (Proxy :: Proxy Point) pointSchemaJSON

69− context "Point5 (many field record)" $ do

70− checkToSchema (Proxy :: Proxy Point5) point5SchemaJSON

71− checkProperties (Proxy :: Proxy Point5) point5Properties

7261 context "Color (bounded enum)" $ checkToSchema (Proxy :: Proxy Color) colorSchemaJSON

7362 context "Shade (paramSchemaToNamedSchema)" $ checkToSchema (Proxy :: Proxy Shade) shadeSchemaJSON

7463 context "Paint (record with bounded enum field)" $ checkToSchema (Proxy :: Proxy Paint) paintSchemaJSON

@@ -77,10 +66,8 @@ spec = do

7766 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON

7867 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON

7968 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON

80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON

8169 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON

8270 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

8471 context "Sum types" $ do

8572 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON

8673 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON

@@ -96,7 +83,6 @@ spec = do

9683 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]

9784 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

9885 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]

10086 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

10187 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []

10288 describe "Inlining Schemas" $ do

@@ -105,10 +91,512 @@ spec = do

10591 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

10692 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

10793 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

11294

11395main :: IO ()

11496main = hspec spec

97+

98+-- ========================================================================

99+-- Person (simple record with optional fields)

100+-- ========================================================================

101+data Person = Person

102+ { name :: String

103+ , phone :: Integer

104+ , email :: Maybe String

105+ } deriving (Generic)

106+

107+instance ToSchema Person

108+

109+personSchemaJSON :: Value

110+personSchemaJSON = [aesonQQ|

111+{

112+ "type": "object",

113+ "properties":

114+ {

115+ "name": { "type": "string" },

116+ "phone": { "type": "integer" },

117+ "email": { "type": "string" }

118+ },

119+ "required": ["name", "phone"]

120+}

121+|]

122+

123+-- ========================================================================

124+-- ISPair (non-record product data type)

125+-- ========================================================================

126+data ISPair = ISPair Integer String

127+ deriving (Generic)

128+

129+instance ToSchema ISPair

130+

131+ispairSchemaJSON :: Value

132+ispairSchemaJSON = [aesonQQ|

133+{

134+ "type": "array",

135+ "items":

136+ [

137+ { "type": "integer" },

138+ { "type": "string" }

139+ ]

140+}

141+|]

142+

143+-- ========================================================================

144+-- Point (record data type with custom fieldLabelModifier)

145+-- ========================================================================

146+data Point = Point

147+ { pointX :: Double

148+ , pointY :: Double

149+ } deriving (Generic)

150+

151+instance ToSchema Point where

152+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

153+ { fieldLabelModifier = map toLower . drop (length "point") }

154+

155+pointSchemaJSON :: Value

156+pointSchemaJSON = [aesonQQ|

157+{

158+ "type": "object",

159+ "properties":

160+ {

161+ "x": { "type": "number", "format": "double" },

162+ "y": { "type": "number", "format": "double" }

163+ },

164+ "required": ["x", "y"]

165+}

166+|]

167+

168+

169+-- ========================================================================

170+-- Color (enum)

171+-- ========================================================================

172+data Color

173+ = Red

174+ | Green

175+ | Blue

176+ deriving (Generic)

177+instance ToSchema Color

178+

179+colorSchemaJSON :: Value

180+colorSchemaJSON = [aesonQQ|

181+{

182+ "type": "string",

183+ "enum": ["Red", "Green", "Blue"]

184+}

185+|]

186+

187+-- ========================================================================

188+-- Shade (paramSchemaToNamedSchema)

189+-- ========================================================================

190+

191+data Shade = Dim | Bright deriving (Generic)

192+instance ToParamSchema Shade

193+

194+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions

195+

196+shadeSchemaJSON :: Value

197+shadeSchemaJSON = [aesonQQ|

198+{

199+ "type": "string",

200+ "enum": ["Dim", "Bright"]

201+}

202+|]

203+

204+-- ========================================================================

205+-- Paint (record with bounded enum property)

206+-- ========================================================================

207+

208+newtype Paint = Paint { color :: Color }

209+ deriving (Generic)

210+instance ToSchema Paint

211+

212+paintSchemaJSON :: Value

213+paintSchemaJSON = [aesonQQ|

214+{

215+ "type": "object",

216+ "properties":

217+ {

218+ "color":

219+ {

220+ "$ref": "#/definitions/Color"

221+ }

222+ },

223+ "required": ["color"]

224+}

225+|]

226+

227+paintInlinedSchemaJSON :: Value

228+paintInlinedSchemaJSON = [aesonQQ|

229+{

230+ "type": "object",

231+ "properties":

232+ {

233+ "color":

234+ {

235+ "type": "string",

236+ "enum": ["Red", "Green", "Blue"]

237+ }

238+ },

239+ "required": ["color"]

240+}

241+|]

242+

243+-- ========================================================================

244+-- Email (newtype with unwrapUnaryRecords set to True)

245+-- ========================================================================

246+

247+newtype Email = Email { getEmail :: String }

248+ deriving (Generic)

249+

250+instance ToSchema Email where

251+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

252+ { unwrapUnaryRecords = True }

253+

254+emailSchemaJSON :: Value

255+emailSchemaJSON = [aesonQQ|

256+{

257+ "type": "string"

258+}

259+|]

260+

261+-- ========================================================================

262+-- UserId (non-record newtype)

263+-- ========================================================================

264+

265+newtype UserId = UserId Integer

266+ deriving (Eq, Ord, Generic)

267+instance ToSchema UserId

268+

269+userIdSchemaJSON :: Value

270+userIdSchemaJSON = [aesonQQ|

271+{

272+ "type": "integer"

273+}

274+|]

275+

276+-- ========================================================================

277+-- UserGroup (set newtype)

278+-- ========================================================================

279+

280+newtype UserGroup = UserGroup (Set UserId)

281+ deriving (Generic)

282+instance ToSchema UserGroup

283+

284+userGroupSchemaJSON :: Value

285+userGroupSchemaJSON = [aesonQQ|

286+{

287+ "type": "array",

288+ "items": { "$ref": "#/definitions/UserId" },

289+ "uniqueItems": true

290+}

291+|]

292+

293+-- ========================================================================

294+-- Player (record newtype)

295+-- ========================================================================

296+

297+newtype Player = Player

298+ { position :: Point

299+ } deriving (Generic)

300+instance ToSchema Player

301+

302+playerSchemaJSON :: Value

303+playerSchemaJSON = [aesonQQ|

304+{

305+ "type": "object",

306+ "properties":

307+ {

308+ "position":

309+ {

310+ "$ref": "#/definitions/Point"

311+ }

312+ },

313+ "required": ["position"]

314+}

315+|]

316+

317+-- ========================================================================

318+-- MyRoseTree (custom datatypeNameModifier)

319+-- ========================================================================

320+

321+data MyRoseTree = MyRoseTree

322+ { root :: String

323+ , trees :: [MyRoseTree]

324+ } deriving (Generic)

325+

326+instance ToSchema MyRoseTree where

327+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

328+ { datatypeNameModifier = drop (length "My") }

329+

330+myRoseTreeSchemaJSON :: Value

331+myRoseTreeSchemaJSON = [aesonQQ|

332+{

333+ "type": "object",

334+ "properties":

335+ {

336+ "root": { "type": "string" },

337+ "trees":

338+ {

339+ "type": "array",

340+ "items":

341+ {

342+ "$ref": "#/definitions/RoseTree"

343+ }

344+ }

345+ },

346+ "required": ["root", "trees"]

347+}

348+|]

349+

350+-- ========================================================================

351+-- Inlined (newtype for inlining schemas)

352+-- ========================================================================

353+

354+newtype Inlined a = Inlined { getInlined :: a }

355+

356+instance ToSchema a => ToSchema (Inlined a) where

357+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

358+ where

359+ unname (NamedSchema _ s) = NamedSchema Nothing s

360+

361+newtype Players = Players [Inlined Player]

362+ deriving (Generic)

363+instance ToSchema Players

364+

365+playersSchemaJSON :: Value

366+playersSchemaJSON = [aesonQQ|

367+{

368+ "type": "array",

369+ "items":

370+ {

371+ "type": "object",

372+ "properties":

373+ {

374+ "position":

375+ {

376+ "$ref": "#/definitions/Point"

377+ }

378+ },

379+ "required": ["position"]

380+ }

381+}

382+|]

383+

384+-- ========================================================================

385+-- Status (sum type with unary constructors)

386+-- ========================================================================

387+

388+data Status

389+ = StatusOk String

390+ | StatusError String

391+ deriving (Generic)

392+

393+instance ToSchema Status where

394+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

395+ { constructorTagModifier = map toLower . drop (length "Status") }

396+

397+statusSchemaJSON :: Value

398+statusSchemaJSON = [aesonQQ|

399+{

400+ "type": "object",

401+ "properties":

402+ {

403+ "ok": { "type": "string" },

404+ "error": { "type": "string" }

405+ },

406+ "maxProperties": 1,

407+ "minProperties": 1

408+}

409+|]

410+

411+-- ========================================================================

412+-- Unit type

413+-- ========================================================================

414+

415+data Unit = Unit deriving (Generic)

416+instance ToSchema Unit

417+

418+unitSchemaJSON :: Value

419+unitSchemaJSON = [aesonQQ|

420+{

421+ "type": "string",

422+ "enum": ["Unit"]

423+}

424+|]

425+

426+

427+-- ========================================================================

428+-- Character (sum type with ref and record in alternative)

429+-- ========================================================================

430+

431+data Character

432+ = PC Player

433+ | NPC { npcName :: String, npcPosition :: Point }

434+ deriving (Generic)

435+instance ToSchema Character

436+

437+characterSchemaJSON :: Value

438+characterSchemaJSON = [aesonQQ|

439+{

440+ "type": "object",

441+ "properties":

442+ {

443+ "PC": { "$ref": "#/definitions/Player" },

444+ "NPC":

445+ {

446+ "type": "object",

447+ "properties":

448+ {

449+ "npcName": { "type": "string" },

450+ "npcPosition": { "$ref": "#/definitions/Point" }

451+ },

452+ "required": ["npcName", "npcPosition"]

453+ }

454+ },

455+ "maxProperties": 1,

456+ "minProperties": 1

457+}

458+|]

459+

460+characterInlinedSchemaJSON :: Value

461+characterInlinedSchemaJSON = [aesonQQ|

462+{

463+ "type": "object",

464+ "properties":

465+ {

466+ "PC":

467+ {

468+ "type": "object",

469+ "properties":

470+ {

471+ "position":

472+ {

473+ "type": "object",

474+ "properties":

475+ {

476+ "x": { "type": "number", "format": "double" },

477+ "y": { "type": "number", "format": "double" }

478+ },

479+ "required": ["x", "y"]

480+ }

481+ },

482+ "required": ["position"]

483+ },

484+ "NPC":

485+ {

486+ "type": "object",

487+ "properties":

488+ {

489+ "npcName": { "type": "string" },

490+ "npcPosition":

491+ {

492+ "type": "object",

493+ "properties":

494+ {

495+ "x": { "type": "number", "format": "double" },

496+ "y": { "type": "number", "format": "double" }

497+ },

498+ "required": ["x", "y"]

499+ }

500+ },

501+ "required": ["npcName", "npcPosition"]

502+ }

503+ },

504+ "maxProperties": 1,

505+ "minProperties": 1

506+}

507+|]

508+

509+characterInlinedPlayerSchemaJSON :: Value

510+characterInlinedPlayerSchemaJSON = [aesonQQ|

511+{

512+ "type": "object",

513+ "properties":

514+ {

515+ "PC":

516+ {

517+ "type": "object",

518+ "properties":

519+ {

520+ "position":

521+ {

522+ "$ref": "#/definitions/Point"

523+ }

524+ },

525+ "required": ["position"]

526+ },

527+ "NPC":

528+ {

529+ "type": "object",

530+ "properties":

531+ {

532+ "npcName": { "type": "string" },

533+ "npcPosition": { "$ref": "#/definitions/Point" }

534+ },

535+ "required": ["npcName", "npcPosition"]

536+ }

537+ },

538+ "maxProperties": 1,

539+ "minProperties": 1

540+}

541+|]

542+

543+-- ========================================================================

544+-- Light (sum type with unwrapUnaryRecords)

545+-- ========================================================================

546+

547+data Light

548+ = NoLight

549+ | LightFreq Double

550+ | LightColor Color

551+ | LightWaveLength { waveLength :: Double }

552+ deriving (Generic)

553+

554+instance ToSchema Light where

555+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

556+ { unwrapUnaryRecords = True }

557+

558+lightSchemaJSON :: Value

559+lightSchemaJSON = [aesonQQ|

560+{

561+ "type": "object",

562+ "properties":

563+ {

564+ "NoLight": { "type": "array", "items": [] },

565+ "LightFreq": { "type": "number", "format": "double" },

566+ "LightColor": { "$ref": "#/definitions/Color" },

567+ "LightWaveLength": { "type": "number", "format": "double" }

568+ },

569+ "maxProperties": 1,

570+ "minProperties": 1

571+}

572+|]

573+

574+lightInlinedSchemaJSON :: Value

575+lightInlinedSchemaJSON = [aesonQQ|

576+{

577+ "type": "object",

578+ "properties":

579+ {

580+ "NoLight": { "type": "array", "items": [] },

581+ "LightFreq": { "type": "number", "format": "double" },

582+ "LightColor":

583+ {

584+ "type": "string",

585+ "enum": ["Red", "Green", "Blue"]

586+ },

587+ "LightWaveLength": { "type": "number", "format": "double" }

588+ },

589+ "maxProperties": 1,

590+ "minProperties": 1

591+}

592+|]

593+

594+-- ========================================================================

595+-- ResourceId (series of newtypes)

596+-- ========================================================================

597+

598+newtype Id = Id String deriving (Generic)

599+instance ToSchema Id

600+

601+newtype ResourceId = ResourceId Id deriving (Generic)

602+instance ToSchema ResourceId

test/Data/SwaggerSpec.hs+330−426

@@ -10,9 +10,8 @@ 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

1615import Data.Text (Text)

1716

1817import Data.Swagger

@@ -21,14 +20,6 @@ import Test.Hspec hiding (example)

2120

2221spec :: Spec

2322spec = do

24− describe "host" $ do

25− it "can decode the host port" $ do

26− let h = Just $ Host "localhost" (Just (fromInteger 8000))

27− swagger :: Swagger

28− swagger = swaggerExample

29− & host .~ h

30− parsed :: Swagger = either error id $ eitherDecode' $ encode swagger

31− parsed ^. host `shouldBe` h

3223 describe "License Object" $ licenseExample <=> licenseExampleJSON

3324 describe "Contact Object" $ contactExample <=> contactExampleJSON

3425 describe "Info Object" $ infoExample <=> infoExampleJSON

@@ -37,14 +28,11 @@ spec = do

3728 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON

3829 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON

3930 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON

40− context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON

4131 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

4232 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

4333 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

4434 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

4535 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

4836 describe "Swagger Object" $ do

4937 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

5038 context "PetStore Example" $

@@ -110,8 +98,7 @@ contactExampleJSON = [aesonQQ|

11098-- =======================================================================

11199

112100licenseExample :: License

113−licenseExample = "Apache 2.0"

114− & url ?~ URL "http://www.apache.org/licenses/LICENSE-2.0.html"

101+licenseExample = License "Apache 2.0" (Just (URL "http://www.apache.org/licenses/LICENSE-2.0.html"))

115102

116103licenseExampleJSON :: Value

117104licenseExampleJSON = [aesonQQ|

@@ -128,7 +115,7 @@ licenseExampleJSON = [aesonQQ|

128115

129116operationExample :: Operation

130117operationExample = mempty

131− & tags .~ InsOrdHS.fromList ["pet"]

118+ & tags .~ ["pet"]

132119 & summary ?~ "Updates a pet in the store with form data"

133120 & description ?~ ""

134121 & operationId ?~ "updatePetWithForm"

@@ -152,14 +139,15 @@ operationExample = mempty

152139 & schema .~ ParamOther (stringSchema ParamFormData)

153140 ]

154141

155− & at 200 ?~ "Pet updated."

156− & at 405 ?~ "Invalid input"

142+ & responses .~ (mempty & responses .~

143+ [ (200, Inline (mempty & description .~ "Pet updated."))

144+ , (405, Inline (mempty & description .~ "Invalid input")) ])

157145 & security .~ [SecurityRequirement [("petstore_auth", ["write:pets", "read:pets"])]]

158146 where

159147 stringSchema :: ParamLocation -> ParamOtherSchema

160148 stringSchema loc = mempty

161149 & in_ .~ loc

162− & type_ ?~ SwaggerString

150+ & type_ .~ SwaggerString

163151

164152operationExampleJSON :: Value

165153operationExampleJSON = [aesonQQ|

@@ -225,7 +213,7 @@ operationExampleJSON = [aesonQQ|

225213

226214schemaPrimitiveExample :: Schema

227215schemaPrimitiveExample = mempty

228− & type_ ?~ SwaggerString

216+ & type_ .~ SwaggerString

229217 & format ?~ "email"

230218

231219schemaPrimitiveExampleJSON :: Value

@@ -238,14 +226,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

238226

239227schemaSimpleModelExample :: Schema

240228schemaSimpleModelExample = mempty

241− & type_ ?~ SwaggerObject

229+ & type_ .~ SwaggerObject

242230 & required .~ [ "name" ]

243231 & properties .~

244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))

232+ [ ("name", Inline (mempty & type_ .~ SwaggerString))

245233 , ("address", Ref (Reference "Address"))

246234 , ("age", Inline $ mempty

247235 & minimum_ ?~ 0

248− & type_ ?~ SwaggerInteger

236+ & type_ .~ SwaggerInteger

249237 & format ?~ "int32" ) ]

250238

251239schemaSimpleModelExampleJSON :: Value

@@ -273,8 +261,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

273261

274262schemaModelDictExample :: Schema

275263schemaModelDictExample = mempty

276− & type_ ?~ SwaggerObject

277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

264+ & type_ .~ SwaggerObject

265+ & additionalProperties ?~ (mempty & type_ .~ SwaggerString)

278266

279267schemaModelDictExampleJSON :: Value

280268schemaModelDictExampleJSON = [aesonQQ|

@@ -286,28 +274,15 @@ schemaModelDictExampleJSON = [aesonQQ|

286274}

287275|]

288276

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−

302277schemaWithExampleExample :: Schema

303278schemaWithExampleExample = mempty

304− & type_ ?~ SwaggerObject

279+ & type_ .~ SwaggerObject

305280 & properties .~

306281 [ ("id", Inline $ mempty

307− & type_ ?~ SwaggerInteger

282+ & type_ .~ SwaggerInteger

308283 & format ?~ "int64" )

309284 , ("name", Inline $ mempty

310− & type_ ?~ SwaggerString) ]

285+ & type_ .~ SwaggerString) ]

311286 & required .~ [ "name" ]

312287 & example ?~ [aesonQQ|

313288 {

@@ -346,19 +321,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

346321definitionsExample :: HashMap Text Schema

347322definitionsExample =

348323 [ ("Category", mempty

349− & type_ ?~ SwaggerObject

324+ & type_ .~ SwaggerObject

350325 & properties .~

351326 [ ("id", Inline $ mempty

352− & type_ ?~ SwaggerInteger

327+ & type_ .~ SwaggerInteger

353328 & format ?~ "int64")

354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

329+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

355330 , ("Tag", mempty

356− & type_ ?~ SwaggerObject

331+ & type_ .~ SwaggerObject

357332 & properties .~

358333 [ ("id", Inline $ mempty

359− & type_ ?~ SwaggerInteger

334+ & type_ .~ SwaggerInteger

360335 & format ?~ "int64")

361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

336+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

362337

363338definitionsExampleJSON :: Value

364339definitionsExampleJSON = [aesonQQ|

@@ -402,7 +377,7 @@ paramsDefinitionExample =

402377 & required ?~ True

403378 & schema .~ ParamOther (mempty

404379 & in_ .~ ParamQuery

405− & type_ ?~ SwaggerInteger

380+ & type_ .~ SwaggerInteger

406381 & format ?~ "int32" ))

407382 , ("limitParam", mempty

408383 & name .~ "limit"

@@ -410,7 +385,7 @@ paramsDefinitionExample =

410385 & required ?~ True

411386 & schema .~ ParamOther (mempty

412387 & in_ .~ ParamQuery

413− & type_ ?~ SwaggerInteger

388+ & type_ .~ SwaggerInteger

414389 & format ?~ "int32" )) ]

415390

416391paramsDefinitionExampleJSON :: Value

@@ -460,8 +435,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

460435-- Responses Definition object

461436-- =======================================================================

462437

463−securityDefinitionsExample :: SecurityDefinitions

464−securityDefinitionsExample = SecurityDefinitions

438+securityDefinitionsExample :: HashMap Text SecurityScheme

439+securityDefinitionsExample =

465440 [ ("api_key", SecurityScheme

466441 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

467442 , _securitySchemeDescription = Nothing })

@@ -493,46 +468,6 @@ securityDefinitionsExampleJSON = [aesonQQ|

493468}

494469|]

495470

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−

536471-- =======================================================================

537472-- Swagger object

538473-- =======================================================================

@@ -544,25 +479,24 @@ swaggerExample = mempty

544479 & info .~ (mempty

545480 & version .~ "1.0"

546481 & title .~ "Todo API"

547− & license ?~ "MIT"

548− & license._Just.url ?~ URL "http://mit.com"

482+ & license ?~ License "MIT" (Just (URL "http://mit.com"))

549483 & description ?~ "This is a an API that tests servant-swagger support for a Todo API")

550484 & paths.at "/todo/{id}" ?~ (mempty & get ?~ ((mempty :: Operation)

551485 & at 200 ?~ Inline (mempty

552486 & description .~ "OK"

553487 & schema ?~ Inline (mempty

554− & type_ ?~ SwaggerObject

488+ & type_ .~ SwaggerObject

555489 & example ?~ [aesonQQ|

556490 {

557491 "created": 100,

558492 "description": "get milk"

559493 } |]

560− & description ?~ "This is some real Todo right here"

494+ & description ?~ "This is some real Todo right here"

561495 & properties .~

562496 [ ("created", Inline $ mempty

563− & type_ ?~ SwaggerInteger

497+ & type_ .~ SwaggerInteger

564498 & format ?~ "int32")

565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))

499+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))

566500 & produces ?~ MimeList [ "application/json" ]

567501 & parameters .~

568502 [ Inline $ mempty

@@ -571,8 +505,8 @@ swaggerExample = mempty

571505 & description ?~ "TodoId param"

572506 & schema .~ ParamOther (mempty

573507 & in_ .~ ParamPath

574− & type_ ?~ SwaggerString ) ]

575− & tags .~ InsOrdHS.fromList [ "todo" ] ))

508+ & type_ .~ SwaggerString ) ]

509+ & tags .~ [ "todo" ] ))

576510

577511swaggerExampleJSON :: Value

578512swaggerExampleJSON = [aesonQQ|

@@ -639,130 +573,130 @@ swaggerExampleJSON = [aesonQQ|

639573

640574petstoreExampleJSON :: Value

641575petstoreExampleJSON = [aesonQQ|

642−{

576+{

643577 "swagger":"2.0",

644− "info":{

578+ "info":{

645579 "description":"This is a sample server Petstore server. You can find out more about Swagger at [http://swagger.io](http://swagger.io) or on [irc.freenode.net, #swagger](http://swagger.io/irc/). For this sample, you can use the api key `special-key` to test the authorization filters.",

646580 "version":"1.0.0",

647581 "title":"Swagger Petstore",

648582 "termsOfService":"http://swagger.io/terms/",

649− "contact":{

583+ "contact":{

650584 "email":"apiteam@swagger.io"

651585 },

652− "license":{

586+ "license":{

653587 "name":"Apache 2.0",

654588 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"

655589 }

656590 },

657591 "host":"petstore.swagger.io",

658592 "basePath":"/v2",

659− "tags":[

660− {

593+ "tags":[

594+ {

661595 "name":"pet",

662596 "description":"Everything about your Pets",

663− "externalDocs":{

597+ "externalDocs":{

664598 "description":"Find out more",

665599 "url":"http://swagger.io"

666600 }

667601 },

668− {

602+ {

669603 "name":"store",

670604 "description":"Access to Petstore orders"

671605 },

672− {

606+ {

673607 "name":"user",

674608 "description":"Operations about user",

675− "externalDocs":{

609+ "externalDocs":{

676610 "description":"Find out more about our store",

677611 "url":"http://swagger.io"

678612 }

679613 }

680614 ],

681− "schemes":[

615+ "schemes":[

682616 "http"

683617 ],

684− "paths":{

685− "/pet":{

686− "post":{

687− "tags":[

618+ "paths":{

619+ "/pet":{

620+ "post":{

621+ "tags":[

688622 "pet"

689623 ],

690624 "summary":"Add a new pet to the store",

691625 "description":"",

692626 "operationId":"addPet",

693− "consumes":[

627+ "consumes":[

694628 "application/json",

695629 "application/xml"

696630 ],

697− "produces":[

631+ "produces":[

698632 "application/xml",

699633 "application/json"

700634 ],

701− "parameters":[

702− {

635+ "parameters":[

636+ {

703637 "in":"body",

704638 "name":"body",

705639 "description":"Pet object that needs to be added to the store",

706640 "required":true,

707− "schema":{

641+ "schema":{

708642 "$ref":"#/definitions/Pet"

709643 }

710644 }

711645 ],

712− "responses":{

713− "405":{

646+ "responses":{

647+ "405":{

714648 "description":"Invalid input"

715649 }

716650 },

717− "security":[

718− {

719− "petstore_auth":[

651+ "security":[

652+ {

653+ "petstore_auth":[

720654 "write:pets",

721655 "read:pets"

722656 ]

723657 }

724658 ]

725659 },

726− "put":{

727− "tags":[

660+ "put":{

661+ "tags":[

728662 "pet"

729663 ],

730664 "summary":"Update an existing pet",

731665 "description":"",

732666 "operationId":"updatePet",

733− "consumes":[

667+ "consumes":[

734668 "application/json",

735669 "application/xml"

736670 ],

737− "produces":[

671+ "produces":[

738672 "application/xml",

739673 "application/json"

740674 ],

741− "parameters":[

742− {

675+ "parameters":[

676+ {

743677 "in":"body",

744678 "name":"body",

745679 "description":"Pet object that needs to be added to the store",

746680 "required":true,

747− "schema":{

681+ "schema":{

748682 "$ref":"#/definitions/Pet"

749683 }

750684 }

751685 ],

752− "responses":{

753− "400":{

686+ "responses":{

687+ "400":{

754688 "description":"Invalid ID supplied"

755689 },

756− "404":{

690+ "404":{

757691 "description":"Pet not found"

758692 },

759− "405":{

693+ "405":{

760694 "description":"Validation exception"

761695 }

762696 },

763− "security":[

764− {

765− "petstore_auth":[

697+ "security":[

698+ {

699+ "petstore_auth":[

766700 "write:pets",

767701 "read:pets"

768702 ]

@@ -770,28 +704,28 @@ petstoreExampleJSON = [aesonQQ|

770704 ]

771705 }

772706 },

773− "/pet/findByStatus":{

774− "get":{

775− "tags":[

707+ "/pet/findByStatus":{

708+ "get":{

709+ "tags":[

776710 "pet"

777711 ],

778712 "summary":"Finds Pets by status",

779713 "description":"Multiple status values can be provided with comma seperated strings",

780714 "operationId":"findPetsByStatus",

781− "produces":[

715+ "produces":[

782716 "application/xml",

783717 "application/json"

784718 ],

785− "parameters":[

786− {

719+ "parameters":[

720+ {

787721 "name":"status",

788722 "in":"query",

789723 "description":"Status values that need to be considered for filter",

790724 "required":true,

791725 "type":"array",

792− "items":{

726+ "items":{

793727 "type":"string",

794− "enum":[

728+ "enum":[

795729 "available",

796730 "pending",

797731 "sold"

@@ -801,23 +735,23 @@ petstoreExampleJSON = [aesonQQ|

801735 "collectionFormat":"csv"

802736 }

803737 ],

804− "responses":{

805− "200":{

738+ "responses":{

739+ "200":{

806740 "description":"successful operation",

807− "schema":{

741+ "schema":{

808742 "type":"array",

809− "items":{

743+ "items":{

810744 "$ref":"#/definitions/Pet"

811745 }

812746 }

813747 },

814− "400":{

748+ "400":{

815749 "description":"Invalid status value"

816750 }

817751 },

818− "security":[

819− {

820− "petstore_auth":[

752+ "security":[

753+ {

754+ "petstore_auth":[

821755 "write:pets",

822756 "read:pets"

823757 ]

@@ -825,48 +759,48 @@ petstoreExampleJSON = [aesonQQ|

825759 ]

826760 }

827761 },

828− "/pet/findByTags":{

829− "get":{

830− "tags":[

762+ "/pet/findByTags":{

763+ "get":{

764+ "tags":[

831765 "pet"

832766 ],

833767 "summary":"Finds Pets by tags",

834768 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",

835769 "operationId":"findPetsByTags",

836− "produces":[

770+ "produces":[

837771 "application/xml",

838772 "application/json"

839773 ],

840− "parameters":[

841− {

774+ "parameters":[

775+ {

842776 "name":"tags",

843777 "in":"query",

844778 "description":"Tags to filter by",

845779 "required":true,

846780 "type":"array",

847− "items":{

781+ "items":{

848782 "type":"string"

849783 },

850784 "collectionFormat":"csv"

851785 }

852786 ],

853− "responses":{

854− "200":{

787+ "responses":{

788+ "200":{

855789 "description":"successful operation",

856− "schema":{

790+ "schema":{

857791 "type":"array",

858− "items":{

792+ "items":{

859793 "$ref":"#/definitions/Pet"

860794 }

861795 }

862796 },

863− "400":{

797+ "400":{

864798 "description":"Invalid tag value"

865799 }

866800 },

867− "security":[

868− {

869− "petstore_auth":[

801+ "security":[

802+ {

803+ "petstore_auth":[

870804 "write:pets",

871805 "read:pets"

872806 ]

@@ -874,20 +808,20 @@ petstoreExampleJSON = [aesonQQ|

874808 ]

875809 }

876810 },

877− "/pet/{petId}":{

878− "get":{

879− "tags":[

811+ "/pet/{petId}":{

812+ "get":{

813+ "tags":[

880814 "pet"

881815 ],

882816 "summary":"Find pet by ID",

883817 "description":"Returns a single pet",

884818 "operationId":"getPetById",

885− "produces":[

819+ "produces":[

886820 "application/xml",

887821 "application/json"

888822 ],

889− "parameters":[

890− {

823+ "parameters":[

824+ {

891825 "name":"petId",

892826 "in":"path",

893827 "description":"ID of pet to return",

@@ -896,42 +830,42 @@ petstoreExampleJSON = [aesonQQ|

896830 "format":"int64"

897831 }

898832 ],

899− "responses":{

900− "200":{

833+ "responses":{

834+ "200":{

901835 "description":"successful operation",

902− "schema":{

836+ "schema":{

903837 "$ref":"#/definitions/Pet"

904838 }

905839 },

906− "400":{

840+ "400":{

907841 "description":"Invalid ID supplied"

908842 },

909− "404":{

843+ "404":{

910844 "description":"Pet not found"

911845 }

912846 },

913− "security":[

914− {

847+ "security":[

848+ {

915849 "api_key": []

916850 }

917851 ]

918852 },

919− "post":{

920− "tags":[

853+ "post":{

854+ "tags":[

921855 "pet"

922856 ],

923857 "summary":"Updates a pet in the store with form data",

924858 "description":"",

925859 "operationId":"updatePetWithForm",

926− "consumes":[

860+ "consumes":[

927861 "application/x-www-form-urlencoded"

928862 ],

929− "produces":[

863+ "produces":[

930864 "application/xml",

931865 "application/json"

932866 ],

933− "parameters":[

934− {

867+ "parameters":[

868+ {

935869 "name":"petId",

936870 "in":"path",

937871 "description":"ID of pet that needs to be updated",

@@ -939,14 +873,14 @@ petstoreExampleJSON = [aesonQQ|

939873 "type":"integer",

940874 "format":"int64"

941875 },

942− {

876+ {

943877 "name":"name",

944878 "in":"formData",

945879 "description":"Updated name of the pet",

946880 "required":false,

947881 "type":"string"

948882 },

949− {

883+ {

950884 "name":"status",

951885 "in":"formData",

952886 "description":"Updated status of the pet",

@@ -954,39 +888,39 @@ petstoreExampleJSON = [aesonQQ|

954888 "type":"string"

955889 }

956890 ],

957− "responses":{

958− "405":{

891+ "responses":{

892+ "405":{

959893 "description":"Invalid input"

960894 }

961895 },

962− "security":[

963− {

964− "petstore_auth":[

896+ "security":[

897+ {

898+ "petstore_auth":[

965899 "write:pets",

966900 "read:pets"

967901 ]

968902 }

969903 ]

970904 },

971− "delete":{

972− "tags":[

905+ "delete":{

906+ "tags":[

973907 "pet"

974908 ],

975909 "summary":"Deletes a pet",

976910 "description":"",

977911 "operationId":"deletePet",

978− "produces":[

912+ "produces":[

979913 "application/xml",

980914 "application/json"

981915 ],

982− "parameters":[

983− {

916+ "parameters":[

917+ {

984918 "name":"api_key",

985919 "in":"header",

986920 "required":false,

987921 "type":"string"

988922 },

989− {

923+ {

990924 "name":"petId",

991925 "in":"path",

992926 "description":"Pet id to delete",

@@ -995,14 +929,14 @@ petstoreExampleJSON = [aesonQQ|

995929 "format":"int64"

996930 }

997931 ],

998− "responses":{

999− "400":{

932+ "responses":{

933+ "400":{

1000934 "description":"Invalid pet value"

1001935 }

1002936 },

1003− "security":[

1004− {

1005− "petstore_auth":[

937+ "security":[

938+ {

939+ "petstore_auth":[

1006940 "write:pets",

1007941 "read:pets"

1008942 ]

@@ -1010,22 +944,22 @@ petstoreExampleJSON = [aesonQQ|

1010944 ]

1011945 }

1012946 },

1013− "/pet/{petId}/uploadImage":{

1014− "post":{

1015− "tags":[

947+ "/pet/{petId}/uploadImage":{

948+ "post":{

949+ "tags":[

1016950 "pet"

1017951 ],

1018952 "summary":"uploads an image",

1019953 "description":"",

1020954 "operationId":"uploadFile",

1021− "consumes":[

955+ "consumes":[

1022956 "multipart/form-data"

1023957 ],

1024− "produces":[

958+ "produces":[

1025959 "application/json"

1026960 ],

1027− "parameters":[

1028− {

961+ "parameters":[

962+ {

1029963 "name":"petId",

1030964 "in":"path",

1031965 "description":"ID of pet to update",

@@ -1033,14 +967,14 @@ petstoreExampleJSON = [aesonQQ|

1033967 "type":"integer",

1034968 "format":"int64"

1035969 },

1036− {

970+ {

1037971 "name":"additionalMetadata",

1038972 "in":"formData",

1039973 "description":"Additional data to pass to server",

1040974 "required":false,

1041975 "type":"string"

1042976 },

1043− {

977+ {

1044978 "name":"file",

1045979 "in":"formData",

1046980 "description":"file to upload",

@@ -1048,17 +982,17 @@ petstoreExampleJSON = [aesonQQ|

1048982 "type":"file"

1049983 }

1050984 ],

1051− "responses":{

1052− "200":{

985+ "responses":{

986+ "200":{

1053987 "description":"successful operation",

1054− "schema":{

988+ "schema":{

1055989 "$ref":"#/definitions/ApiResponse"

1056990 }

1057991 }

1058992 },

1059− "security":[

1060− {

1061− "petstore_auth":[

993+ "security":[

994+ {

995+ "petstore_auth":[

1062996 "write:pets",

1063997 "read:pets"

1064998 ]

@@ -1066,87 +1000,87 @@ petstoreExampleJSON = [aesonQQ|

10661000 ]

10671001 }

10681002 },

1069− "/store/inventory":{

1070− "get":{

1071− "tags":[

1003+ "/store/inventory":{

1004+ "get":{

1005+ "tags":[

10721006 "store"

10731007 ],

10741008 "summary":"Returns pet inventories by status",

10751009 "description":"Returns a map of status codes to quantities",

10761010 "operationId":"getInventory",

1077− "produces":[

1011+ "produces":[

10781012 "application/json"

10791013 ],

10801014 "parameters": [],

1081− "responses":{

1082− "200":{

1015+ "responses":{

1016+ "200":{

10831017 "description":"successful operation",

1084− "schema":{

1018+ "schema":{

10851019 "type":"object",

1086− "additionalProperties":{

1020+ "additionalProperties":{

10871021 "type":"integer",

10881022 "format":"int32"

10891023 }

10901024 }

10911025 }

10921026 },

1093− "security":[

1094− {

1027+ "security":[

1028+ {

10951029 "api_key": []

10961030 }

10971031 ]

10981032 }

10991033 },

1100− "/store/order":{

1101− "post":{

1102− "tags":[

1034+ "/store/order":{

1035+ "post":{

1036+ "tags":[

11031037 "store"

11041038 ],

11051039 "summary":"Place an order for a pet",

11061040 "description":"",

11071041 "operationId":"placeOrder",

1108− "produces":[

1042+ "produces":[

11091043 "application/xml",

11101044 "application/json"

11111045 ],

1112− "parameters":[

1113− {

1046+ "parameters":[

1047+ {

11141048 "in":"body",

11151049 "name":"body",

11161050 "description":"order placed for purchasing the pet",

11171051 "required":true,

1118− "schema":{

1052+ "schema":{

11191053 "$ref":"#/definitions/Order"

11201054 }

11211055 }

11221056 ],

1123− "responses":{

1124− "200":{

1057+ "responses":{

1058+ "200":{

11251059 "description":"successful operation",

1126− "schema":{

1060+ "schema":{

11271061 "$ref":"#/definitions/Order"

11281062 }

11291063 },

1130− "400":{

1064+ "400":{

11311065 "description":"Invalid Order"

11321066 }

11331067 }

11341068 }

11351069 },

1136− "/store/order/{orderId}":{

1137− "get":{

1138− "tags":[

1070+ "/store/order/{orderId}":{

1071+ "get":{

1072+ "tags":[

11391073 "store"

11401074 ],

11411075 "summary":"Find purchase order by ID",

11421076 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",

11431077 "operationId":"getOrderById",

1144− "produces":[

1078+ "produces":[

11451079 "application/xml",

11461080 "application/json"

11471081 ],

1148− "parameters":[

1149− {

1082+ "parameters":[

1083+ {

11501084 "name":"orderId",

11511085 "in":"path",

11521086 "description":"ID of pet that needs to be fetched",

@@ -1157,34 +1091,34 @@ petstoreExampleJSON = [aesonQQ|

11571091 "format":"int64"

11581092 }

11591093 ],

1160− "responses":{

1161− "200":{

1094+ "responses":{

1095+ "200":{

11621096 "description":"successful operation",

1163− "schema":{

1097+ "schema":{

11641098 "$ref":"#/definitions/Order"

11651099 }

11661100 },

1167− "400":{

1101+ "400":{

11681102 "description":"Invalid ID supplied"

11691103 },

1170− "404":{

1104+ "404":{

11711105 "description":"Order not found"

11721106 }

11731107 }

11741108 },

1175− "delete":{

1176− "tags":[

1109+ "delete":{

1110+ "tags":[

11771111 "store"

11781112 ],

11791113 "summary":"Delete purchase order by ID",

11801114 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",

11811115 "operationId":"deleteOrder",

1182− "produces":[

1116+ "produces":[

11831117 "application/xml",

11841118 "application/json"

11851119 ],

1186− "parameters":[

1187− {

1120+ "parameters":[

1121+ {

11881122 "name":"orderId",

11891123 "in":"path",

11901124 "description":"ID of the order that needs to be deleted",

@@ -1193,133 +1127,133 @@ petstoreExampleJSON = [aesonQQ|

11931127 "minimum":1.0

11941128 }

11951129 ],

1196− "responses":{

1197− "400":{

1130+ "responses":{

1131+ "400":{

11981132 "description":"Invalid ID supplied"

11991133 },

1200− "404":{

1134+ "404":{

12011135 "description":"Order not found"

12021136 }

12031137 }

12041138 }

12051139 },

1206− "/user":{

1207− "post":{

1208− "tags":[

1140+ "/user":{

1141+ "post":{

1142+ "tags":[

12091143 "user"

12101144 ],

12111145 "summary":"Create user",

12121146 "description":"This can only be done by the logged in user.",

12131147 "operationId":"createUser",

1214− "produces":[

1148+ "produces":[

12151149 "application/xml",

12161150 "application/json"

12171151 ],

1218− "parameters":[

1219− {

1152+ "parameters":[

1153+ {

12201154 "in":"body",

12211155 "name":"body",

12221156 "description":"Created user object",

12231157 "required":true,

1224− "schema":{

1158+ "schema":{

12251159 "$ref":"#/definitions/User"

12261160 }

12271161 }

12281162 ],

1229− "responses":{

1230− "default":{

1163+ "responses":{

1164+ "default":{

12311165 "description":"successful operation"

12321166 }

12331167 }

12341168 }

12351169 },

1236− "/user/createWithArray":{

1237− "post":{

1238− "tags":[

1170+ "/user/createWithArray":{

1171+ "post":{

1172+ "tags":[

12391173 "user"

12401174 ],

12411175 "summary":"Creates list of users with given input array",

12421176 "description":"",

12431177 "operationId":"createUsersWithArrayInput",

1244− "produces":[

1178+ "produces":[

12451179 "application/xml",

12461180 "application/json"

12471181 ],

1248− "parameters":[

1249− {

1182+ "parameters":[

1183+ {

12501184 "in":"body",

12511185 "name":"body",

12521186 "description":"List of user object",

12531187 "required":true,

1254− "schema":{

1188+ "schema":{

12551189 "type":"array",

1256− "items":{

1190+ "items":{

12571191 "$ref":"#/definitions/User"

12581192 }

12591193 }

12601194 }

12611195 ],

1262− "responses":{

1263− "default":{

1196+ "responses":{

1197+ "default":{

12641198 "description":"successful operation"

12651199 }

12661200 }

12671201 }

12681202 },

1269− "/user/createWithList":{

1270− "post":{

1271− "tags":[

1203+ "/user/createWithList":{

1204+ "post":{

1205+ "tags":[

12721206 "user"

12731207 ],

12741208 "summary":"Creates list of users with given input array",

12751209 "description":"",

12761210 "operationId":"createUsersWithListInput",

1277− "produces":[

1211+ "produces":[

12781212 "application/xml",

12791213 "application/json"

12801214 ],

1281− "parameters":[

1282− {

1215+ "parameters":[

1216+ {

12831217 "in":"body",

12841218 "name":"body",

12851219 "description":"List of user object",

12861220 "required":true,

1287− "schema":{

1221+ "schema":{

12881222 "type":"array",

1289− "items":{

1223+ "items":{

12901224 "$ref":"#/definitions/User"

12911225 }

12921226 }

12931227 }

12941228 ],

1295− "responses":{

1296− "default":{

1229+ "responses":{

1230+ "default":{

12971231 "description":"successful operation"

12981232 }

12991233 }

13001234 }

13011235 },

1302− "/user/login":{

1303− "get":{

1304− "tags":[

1236+ "/user/login":{

1237+ "get":{

1238+ "tags":[

13051239 "user"

13061240 ],

13071241 "summary":"Logs user into the system",

13081242 "description":"",

13091243 "operationId":"loginUser",

1310− "produces":[

1244+ "produces":[

13111245 "application/xml",

13121246 "application/json"

13131247 ],

1314− "parameters":[

1315− {

1248+ "parameters":[

1249+ {

13161250 "name":"username",

13171251 "in":"query",

13181252 "description":"The user name for login",

13191253 "required":true,

13201254 "type":"string"

13211255 },

1322− {

1256+ {

13231257 "name":"password",

13241258 "in":"query",

13251259 "description":"The password for login in clear text",

@@ -1327,65 +1261,65 @@ petstoreExampleJSON = [aesonQQ|

13271261 "type":"string"

13281262 }

13291263 ],

1330− "responses":{

1331− "200":{

1264+ "responses":{

1265+ "200":{

13321266 "description":"successful operation",

1333− "schema":{

1267+ "schema":{

13341268 "type":"string"

13351269 },

1336− "headers":{

1337− "X-Rate-Limit":{

1270+ "headers":{

1271+ "X-Rate-Limit":{

13381272 "type":"integer",

13391273 "format":"int32",

13401274 "description":"calls per hour allowed by the user"

13411275 },

1342− "X-Expires-After":{

1276+ "X-Expires-After":{

13431277 "type":"string",

13441278 "format":"date-time",

13451279 "description":"date in UTC when toekn expires"

13461280 }

13471281 }

13481282 },

1349− "400":{

1283+ "400":{

13501284 "description":"Invalid username/password supplied"

13511285 }

13521286 }

13531287 }

13541288 },

1355− "/user/logout":{

1356− "get":{

1357− "tags":[

1289+ "/user/logout":{

1290+ "get":{

1291+ "tags":[

13581292 "user"

13591293 ],

13601294 "summary":"Logs out current logged in user session",

13611295 "description":"",

13621296 "operationId":"logoutUser",

1363− "produces":[

1297+ "produces":[

13641298 "application/xml",

13651299 "application/json"

13661300 ],

13671301 "parameters": [],

1368− "responses":{

1369− "default":{

1302+ "responses":{

1303+ "default":{

13701304 "description":"successful operation"

13711305 }

13721306 }

13731307 }

13741308 },

1375− "/user/{username}":{

1376− "get":{

1377− "tags":[

1309+ "/user/{username}":{

1310+ "get":{

1311+ "tags":[

13781312 "user"

13791313 ],

13801314 "summary":"Get user by user name",

13811315 "description":"",

13821316 "operationId":"getUserByName",

1383− "produces":[

1317+ "produces":[

13841318 "application/xml",

13851319 "application/json"

13861320 ],

1387− "parameters":[

1388− {

1321+ "parameters":[

1322+ {

13891323 "name":"username",

13901324 "in":"path",

13911325 "description":"The name that needs to be fetched. Use user1 for testing. ",

@@ -1393,72 +1327,72 @@ petstoreExampleJSON = [aesonQQ|

13931327 "type":"string"

13941328 }

13951329 ],

1396− "responses":{

1397− "200":{

1330+ "responses":{

1331+ "200":{

13981332 "description":"successful operation",

1399− "schema":{

1333+ "schema":{

14001334 "$ref":"#/definitions/User"

14011335 }

14021336 },

1403− "400":{

1337+ "400":{

14041338 "description":"Invalid username supplied"

14051339 },

1406− "404":{

1340+ "404":{

14071341 "description":"User not found"

14081342 }

14091343 }

14101344 },

1411− "put":{

1412− "tags":[

1345+ "put":{

1346+ "tags":[

14131347 "user"

14141348 ],

14151349 "summary":"Updated user",

14161350 "description":"This can only be done by the logged in user.",

14171351 "operationId":"updateUser",

1418− "produces":[

1352+ "produces":[

14191353 "application/xml",

14201354 "application/json"

14211355 ],

1422− "parameters":[

1423− {

1356+ "parameters":[

1357+ {

14241358 "name":"username",

14251359 "in":"path",

14261360 "description":"name that need to be deleted",

14271361 "required":true,

14281362 "type":"string"

14291363 },

1430− {

1364+ {

14311365 "in":"body",

14321366 "name":"body",

14331367 "description":"Updated user object",

14341368 "required":true,

1435− "schema":{

1369+ "schema":{

14361370 "$ref":"#/definitions/User"

14371371 }

14381372 }

14391373 ],

1440− "responses":{

1441− "400":{

1374+ "responses":{

1375+ "400":{

14421376 "description":"Invalid user supplied"

14431377 },

1444− "404":{

1378+ "404":{

14451379 "description":"User not found"

14461380 }

14471381 }

14481382 },

1449− "delete":{

1450− "tags":[

1383+ "delete":{

1384+ "tags":[

14511385 "user"

14521386 ],

14531387 "summary":"Delete user",

14541388 "description":"This can only be done by the logged in user.",

14551389 "operationId":"deleteUser",

1456− "produces":[

1390+ "produces":[

14571391 "application/xml",

14581392 "application/json"

14591393 ],

1460− "parameters":[

1461− {

1394+ "parameters":[

1395+ {

14621396 "name":"username",

14631397 "in":"path",

14641398 "description":"The name that needs to be deleted",

@@ -1466,237 +1400,207 @@ petstoreExampleJSON = [aesonQQ|

14661400 "type":"string"

14671401 }

14681402 ],

1469− "responses":{

1470− "400":{

1403+ "responses":{

1404+ "400":{

14711405 "description":"Invalid username supplied"

14721406 },

1473− "404":{

1407+ "404":{

14741408 "description":"User not found"

14751409 }

14761410 }

14771411 }

14781412 }

14791413 },

1480− "securityDefinitions":{

1481− "petstore_auth":{

1414+ "securityDefinitions":{

1415+ "petstore_auth":{

14821416 "type":"oauth2",

14831417 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",

14841418 "flow":"implicit",

1485− "scopes":{

1419+ "scopes":{

14861420 "write:pets":"modify pets in your account",

14871421 "read:pets":"read your pets"

14881422 }

14891423 },

1490− "api_key":{

1424+ "api_key":{

14911425 "type":"apiKey",

14921426 "name":"api_key",

14931427 "in":"header"

14941428 }

14951429 },

1496− "definitions":{

1497− "Order":{

1430+ "definitions":{

1431+ "Order":{

14981432 "type":"object",

1499− "properties":{

1500− "id":{

1433+ "properties":{

1434+ "id":{

15011435 "type":"integer",

15021436 "format":"int64"

15031437 },

1504− "petId":{

1438+ "petId":{

15051439 "type":"integer",

15061440 "format":"int64"

15071441 },

1508− "quantity":{

1442+ "quantity":{

15091443 "type":"integer",

15101444 "format":"int32"

15111445 },

1512− "shipDate":{

1446+ "shipDate":{

15131447 "type":"string",

15141448 "format":"date-time"

15151449 },

1516− "status":{

1450+ "status":{

15171451 "type":"string",

15181452 "description":"Order Status",

1519− "enum":[

1453+ "enum":[

15201454 "placed",

15211455 "approved",

15221456 "delivered"

15231457 ]

15241458 },

1525− "complete":{

1459+ "complete":{

15261460 "type":"boolean",

15271461 "default":false

15281462 }

15291463 },

1530− "xml":{

1464+ "xml":{

15311465 "name":"Order"

15321466 }

15331467 },

1534− "Category":{

1468+ "Category":{

15351469 "type":"object",

1536− "properties":{

1537− "id":{

1470+ "properties":{

1471+ "id":{

15381472 "type":"integer",

15391473 "format":"int64"

15401474 },

1541− "name":{

1475+ "name":{

15421476 "type":"string"

15431477 }

15441478 },

1545− "xml":{

1479+ "xml":{

15461480 "name":"Category"

15471481 }

15481482 },

1549− "User":{

1483+ "User":{

15501484 "type":"object",

1551− "properties":{

1552− "id":{

1485+ "properties":{

1486+ "id":{

15531487 "type":"integer",

15541488 "format":"int64"

15551489 },

1556− "username":{

1490+ "username":{

15571491 "type":"string"

15581492 },

1559− "firstName":{

1493+ "firstName":{

15601494 "type":"string"

15611495 },

1562− "lastName":{

1496+ "lastName":{

15631497 "type":"string"

15641498 },

1565− "email":{

1499+ "email":{

15661500 "type":"string"

15671501 },

1568− "password":{

1502+ "password":{

15691503 "type":"string"

15701504 },

1571− "phone":{

1505+ "phone":{

15721506 "type":"string"

15731507 },

1574− "userStatus":{

1508+ "userStatus":{

15751509 "type":"integer",

15761510 "format":"int32",

15771511 "description":"User Status"

15781512 }

15791513 },

1580− "xml":{

1514+ "xml":{

15811515 "name":"User"

15821516 }

15831517 },

1584− "Tag":{

1518+ "Tag":{

15851519 "type":"object",

1586− "properties":{

1587− "id":{

1520+ "properties":{

1521+ "id":{

15881522 "type":"integer",

15891523 "format":"int64"

15901524 },

1591− "name":{

1525+ "name":{

15921526 "type":"string"

15931527 }

15941528 },

1595− "xml":{

1529+ "xml":{

15961530 "name":"Tag"

15971531 }

15981532 },

1599− "Pet":{

1533+ "Pet":{

16001534 "type":"object",

1601− "required":[

1535+ "required":[

16021536 "name",

16031537 "photoUrls"

16041538 ],

1605− "properties":{

1606− "id":{

1539+ "properties":{

1540+ "id":{

16071541 "type":"integer",

16081542 "format":"int64"

16091543 },

1610− "category":{

1544+ "category":{

16111545 "$ref":"#/definitions/Category"

16121546 },

1613− "name":{

1547+ "name":{

16141548 "type":"string",

16151549 "example":"doggie"

16161550 },

1617− "photoUrls":{

1551+ "photoUrls":{

16181552 "type":"array",

1619− "xml":{

1553+ "xml":{

16201554 "name":"photoUrl",

16211555 "wrapped":true

16221556 },

1623− "items":{

1557+ "items":{

16241558 "type":"string"

16251559 }

16261560 },

1627− "tags":{

1561+ "tags":{

16281562 "type":"array",

1629− "xml":{

1563+ "xml":{

16301564 "name":"tag",

16311565 "wrapped":true

16321566 },

1633− "items":{

1567+ "items":{

16341568 "$ref":"#/definitions/Tag"

16351569 }

16361570 },

1637− "status":{

1571+ "status":{

16381572 "type":"string",

16391573 "description":"pet status in the store",

1640− "enum":[

1574+ "enum":[

16411575 "available",

16421576 "pending",

16431577 "sold"

16441578 ]

16451579 }

16461580 },

1647− "xml":{

1581+ "xml":{

16481582 "name":"Pet"

16491583 }

16501584 },

1651− "ApiResponse":{

1585+ "ApiResponse":{

16521586 "type":"object",

1653− "properties":{

1654− "code":{

1587+ "properties":{

1588+ "code":{

16551589 "type":"integer",

16561590 "format":"int32"

16571591 },

1658− "type":{

1592+ "type":{

16591593 "type":"string"

16601594 },

1661− "message":{

1595+ "message":{

16621596 "type":"string"

16631597 }

16641598 }

16651599 }

16661600 },

1667− "externalDocs":{

1601+ "externalDocs":{

16681602 "description":"Find out more about Swagger",

16691603 "url":"http://swagger.io"

16701604 }

16711605}

16721606|]

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/SpecCommon.hs+2−7

@@ -1,7 +1,6 @@

11module SpecCommon where

33import Data.Aeson

4−import Data.ByteString.Builder (toLazyByteString)

54import qualified Data.Foldable as F

65import qualified Data.HashMap.Strict as HashMap

76import qualified Data.Vector as Vector

@@ -22,9 +21,5 @@ x <=> js = do

2221 toJSON x `shouldBe` js

2322 it "decodes correctly" $ do

2423 fromJSON js `shouldBe` Success x

25− it "roundtrips: eitherDecode . encode" $ do

26− eitherDecode (encode x) `shouldBe` Right x

27− it "roundtrips with toJSON" $ do

28− eitherDecode (encode $ toJSON x) `shouldBe` Right x

29− it "roundtrips with toEncoding" $ do

30− eitherDecode (toLazyByteString $ fromEncoding $ toEncoding x) `shouldBe` Right x

24+

25+

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