master..baee645 · typeable/swagger2

git.iko.soy/typeable/swagger2

39 files changed+1568−4740

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+11−101 src/Data/Swagger/Declare.hs+5−83 src/Data/Swagger/Internal.hs+141−381 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+77−264 src/Data/Swagger/Internal/TypeShape.hs−66 src/Data/Swagger/Internal/Utils.hs+46−9 src/Data/Swagger/Lens.hs+10−27 src/Data/Swagger/Operation.hs+24−116 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+5−12 src/Data/Swagger/SchemaOptions.hs−35 stack-lts-2.yaml+5 stack.yaml+3−7 swagger2.cabal+42−101 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+65−130 test/Data/Swagger/SchemaSpec.hs+513−25 test/Data/SwaggerSpec.hs+325−420 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+11−101

@@ -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,44 @@ 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"]

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

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

195173-- :}

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\"}}}"

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

197175--

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

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

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

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

202179--

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

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

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

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

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

207184--

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

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

210187-- >>> :{

211188-- encode $ (mempty :: Schema)

212−-- & type_ ?~ SwaggerBoolean

189+-- & type_ .~ SwaggerBoolean

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

214191-- :}

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

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

216193--

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

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

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

220197--

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

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

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

223200--

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

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

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

237214--

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

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

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

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

241218

242219-- $schema

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

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

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

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

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

336259--

337260

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+141−381

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

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

32{-# LANGUAGE DeriveDataTypeable #-}

43{-# LANGUAGE DeriveFunctor #-}

54{-# LANGUAGE DeriveGeneric #-}

@@ -12,66 +11,36 @@

1211{-# LANGUAGE RecordWildCards #-}

1312{-# LANGUAGE ScopedTypeVariables #-}

1413{-# LANGUAGE StandaloneDeriving #-}

15−{-# LANGUAGE TemplateHaskell #-}

16−{-# LANGUAGE TypeFamilies #-}

1714{-# LANGUAGE UndecidableInstances #-}

18−#if __GLASGOW_HASKELL__ <710

19−{-# LANGUAGE PolyKinds #-}

20−#endif

2115#include "overlapping-compat.h"

2216module Data.Swagger.Internal where

2317

2418import Prelude ()

2519import Prelude.Compat

2620

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

2821import Control.Applicative

22+import Control.Monad

2923import Data.Aeson

3024import qualified Data.Aeson.Types as JSON

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

32−import Data.Hashable (Hashable)

26+import Data.HashMap.Strict (HashMap)

3327import qualified Data.HashMap.Strict as HashMap

34−import Data.HashSet.InsOrd (InsOrdHashSet)

3528import Data.Map (Map)

3629import qualified Data.Map as Map

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

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

30+import Data.Monoid

3931import Data.Scientific (Scientific)

4032import Data.String (IsString(..))

4133import Data.Text (Text)

4234import qualified Data.Text as Text

4335import GHC.Generics (Generic)

44−import Network.Socket (HostName, PortNumber)

36+import Network (HostName, PortNumber)

4537import Network.HTTP.Media (MediaType)

4638import Text.Read (readMaybe)

4739

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)

6040import Data.Swagger.Internal.Utils

6141

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−

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

74−type Definitions = InsOrdHashMap Text

43+type Definitions = HashMap Text

7544

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

7746data Swagger = Swagger

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

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

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

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

106− , _swaggerPaths :: InsOrdHashMap FilePath PathItem

75+ , _swaggerPaths :: HashMap FilePath PathItem

10776

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

10978 , _swaggerDefinitions :: Definitions Schema

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

11786 , _swaggerResponses :: Definitions Response

11887

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

120− , _swaggerSecurityDefinitions :: SecurityDefinitions

89+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme

12190

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

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

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

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

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

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

133− , _swaggerTags :: InsOrdHashSet Tag

102+ , _swaggerTags :: [Tag]

134103

135104 -- | Additional external documentation.

136105 , _swaggerExternalDocs :: Maybe ExternalDocs

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

252221data Operation = Operation

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

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

255− _operationTags :: InsOrdHashSet TagName

224+ _operationTags :: [TagName]

256225

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

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

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

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

310279

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

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

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

313282

314283mimeListConstr :: Constr

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

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

360329 -- Default value is @False@.

361330 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool

362331

363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema

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

332+ , _paramOtherSchemaParamSchema :: ParamSchema ParamOtherSchema

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

365334

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

367336--

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

374343--

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

376345data SwaggerItems t where

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

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

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

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

347+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems Schema

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

380349 deriving (Typeable)

381350

382351deriving instance Eq (SwaggerItems t)

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

386355swaggerItemsPrimitiveConstr :: Constr

387356swaggerItemsPrimitiveConstr = mkConstr swaggerItemsDataType "SwaggerItemsPrimitive" [] Prefix

388357

389−swaggerItemsObjectConstr :: Constr

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

391−

392−swaggerItemsArrayConstr :: Constr

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

394−

395358swaggerItemsDataType :: DataType

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

397360

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

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

403362 gunfold k z c = case constrIndex c of

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

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

406365 toConstr _ = swaggerItemsPrimitiveConstr

407366 dataTypeOf _ = swaggerItemsDataType

408367

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

368+deriving instance Data (SwaggerItems Schema)

449369

450370data SwaggerType t where

451371 SwaggerString :: SwaggerType t

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

453373 SwaggerInteger :: SwaggerType t

454374 SwaggerBoolean :: SwaggerType t

455375 SwaggerArray :: SwaggerType t

456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema

457− SwaggerNull :: SwaggerType 'SwaggerKindSchema

458− SwaggerObject :: SwaggerType 'SwaggerKindSchema

376+ SwaggerFile :: SwaggerType ParamOtherSchema

377+ SwaggerNull :: SwaggerType Schema

378+ SwaggerObject :: SwaggerType Schema

459379 deriving (Typeable)

460380

461381deriving instance Eq (SwaggerType t)

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

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

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

466386

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

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

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

469389

470−swaggerCommonTypes :: [SwaggerType k]

390+swaggerCommonTypes :: [SwaggerType t]

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

472392

473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]

393+swaggerParamTypes :: [SwaggerType ParamOtherSchema]

474394swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]

475395

476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]

396+swaggerSchemaTypes :: [SwaggerType Schema]

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

478398

479399swaggerTypeConstrs :: [Constr]

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

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

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

482402

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

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

484404 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes

485405 toConstr = swaggerTypeConstr

486406 dataTypeOf = swaggerTypeDataType

487407

488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where

408+instance OVERLAPPABLE_ Data (SwaggerType ParamOtherSchema) where

489409 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes

490410 toConstr = swaggerTypeConstr

491411 dataTypeOf = swaggerTypeDataType

492412

493−instance Data (SwaggerType 'SwaggerKindSchema) where

413+instance OVERLAPPABLE_ Data (SwaggerType Schema) where

494414 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes

495415 toConstr = swaggerTypeConstr

496416 dataTypeOf = swaggerTypeDataType

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

530450 -- Corresponds to multiple parameter instances

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

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

533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema

453+ CollectionMulti :: CollectionFormat ParamOtherSchema

534454 deriving (Typeable)

535455

536456deriving instance Eq (CollectionFormat t)

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

546466collectionCommonFormats :: [CollectionFormat t]

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

548468

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

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

550470 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats

551471 toConstr = collectionFormatConstr

552472 dataTypeOf _ = collectionFormatDataType

553473

554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)

474+deriving instance OVERLAPPABLE_ Data (CollectionFormat ParamOtherSchema)

555475

556476type ParamName = Text

557477

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

560480 , _schemaDescription :: Maybe Text

561481 , _schemaRequired :: [ParamName]

562482

563− , _schemaAllOf :: Maybe [Referenced Schema]

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

565− , _schemaAdditionalProperties :: Maybe AdditionalProperties

483+ , _schemaAllOf :: Maybe [Schema]

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

485+ , _schemaAdditionalProperties :: Maybe Schema

566486

567487 , _schemaDiscriminator :: Maybe Text

568488 , _schemaReadOnly :: Maybe Bool

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

573493 , _schemaMaxProperties :: Maybe Integer

574494 , _schemaMinProperties :: Maybe Integer

575495

576− , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema

496+ , _schemaParamSchema :: ParamSchema Schema

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

578498

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

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

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

587507type Pattern = Text

588508

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

509+data ParamSchema t = ParamSchema

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

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

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

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

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

595515 _paramSchemaDefault :: Maybe Value

596516

597− , _paramSchemaType :: Maybe (SwaggerType t)

517+ , _paramSchemaType :: SwaggerType t

598518 , _paramSchemaFormat :: Maybe Format

599519 , _paramSchemaItems :: Maybe (SwaggerItems t)

600520 , _paramSchemaMaximum :: Maybe Scientific

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

611531 , _paramSchemaMultipleOf :: Maybe Scientific

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

613533

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

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

615535

616536data Xml = Xml

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

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

653573

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

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

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

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

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

658578

659579type HttpStatusCode = Int

@@ -672,7 +592,7 @@ data Response = Response

672592 , _responseSchema :: Maybe (Referenced Schema)

673593

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

675− , _responseHeaders :: InsOrdHashMap HeaderName Header

595+ , _responseHeaders :: HashMap HeaderName Header

676596

677597 -- | An example of the response message.

678598 , _responseExamples :: Maybe Example

@@ -687,7 +607,7 @@ data Header = Header

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

688608 _headerDescription :: Maybe Text

689609

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

610+ , _headerParamSchema :: ParamSchema Header

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

692612

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

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

738658 _oauth2Flow :: OAuth2Flow

739659

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

741− , _oauth2Scopes :: InsOrdHashMap Text Text

661+ , _oauth2Scopes :: HashMap Text Text

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

743663

744664data SecuritySchemeType

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

755675 , _securitySchemeDescription :: Maybe Text

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

757677

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−

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

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

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

777681newtype SecurityRequirement = SecurityRequirement

778− { getSecurityRequirement :: InsOrdHashMap Text [Text]

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

682+ { getSecurityRequirement :: HashMap Text [Text]

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

780684

781685-- | Tag name.

782686type TagName = Text

@@ -793,9 +697,7 @@ data Tag = Tag

793697

794698 -- | Additional external documentation for this tag.

795699 , _tagExternalDocs :: Maybe ExternalDocs

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

797−

798−instance Hashable Tag

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

799701

800702instance IsString Tag where

801703 fromString s = Tag (fromString s) Nothing Nothing

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

808710

809711 -- | The URL for the target documentation.

810712 , _externalDocsUrl :: URL

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

812−

813−instance Hashable ExternalDocs

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

814714

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

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

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

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

826726 fromString = Inline . fromString

827727

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

829−

830−data AdditionalProperties

831− = AdditionalPropertiesAllowed Bool

832− | AdditionalPropertiesSchema (Referenced Schema)

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

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

834729

835730-- =======================================================================

836731-- Monoid instances

837732-- =======================================================================

838733

839−instance Semigroup Swagger where

840− (<>) = genericMappend

841734instance Monoid Swagger where

842735 mempty = genericMempty

843− mappend = (<>)

736+ mappend = genericMappend

844737

845−instance Semigroup Info where

846− (<>) = genericMappend

847738instance Monoid Info where

848739 mempty = genericMempty

849− mappend = (<>)

740+ mappend = genericMappend

850741

851−instance Semigroup Contact where

852− (<>) = genericMappend

853742instance Monoid Contact where

854743 mempty = genericMempty

855− mappend = (<>)

744+ mappend = genericMappend

856745

857−instance Semigroup PathItem where

858− (<>) = genericMappend

859746instance Monoid PathItem where

860747 mempty = genericMempty

861− mappend = (<>)

748+ mappend = genericMappend

862749

863−instance Semigroup Schema where

864− (<>) = genericMappend

865750instance Monoid Schema where

866751 mempty = genericMempty

867− mappend = (<>)

752+ mappend = genericMappend

868753

869−instance Semigroup (ParamSchema t) where

870− (<>) = genericMappend

871754instance Monoid (ParamSchema t) where

872755 mempty = genericMempty

873− mappend = (<>)

756+ mappend = genericMappend

874757

875−instance Semigroup Param where

876− (<>) = genericMappend

877758instance Monoid Param where

878759 mempty = genericMempty

879− mappend = (<>)

760+ mappend = genericMappend

880761

881−instance Semigroup ParamOtherSchema where

882− (<>) = genericMappend

883762instance Monoid ParamOtherSchema where

884763 mempty = genericMempty

885− mappend = (<>)

764+ mappend = genericMappend

886765

887−instance Semigroup Header where

888− (<>) = genericMappend

889766instance Monoid Header where

890767 mempty = genericMempty

891− mappend = (<>)

768+ mappend = genericMappend

892769

893−instance Semigroup Responses where

894− (<>) = genericMappend

895770instance Monoid Responses where

896771 mempty = genericMempty

897− mappend = (<>)

772+ mappend = genericMappend

898773

899−instance Semigroup Response where

900− (<>) = genericMappend

901774instance Monoid Response where

902775 mempty = genericMempty

903− mappend = (<>)

776+ mappend = genericMappend

904777

905−instance Semigroup ExternalDocs where

906− (<>) = genericMappend

907778instance Monoid ExternalDocs where

908779 mempty = genericMempty

909− mappend = (<>)

780+ mappend = genericMappend

910781

911−instance Semigroup Operation where

912− (<>) = genericMappend

913782instance Monoid Operation where

914783 mempty = genericMempty

915− mappend = (<>)

784+ mappend = genericMappend

916785

917−instance Semigroup Example where

918− (<>) = genericMappend

919786instance Monoid Example where

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

788+ mappend = genericMappend

933789

934790-- =======================================================================

935791-- SwaggerMonoid helper instances

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

945801instance SwaggerMonoid Response

946802instance SwaggerMonoid ExternalDocs

947803instance SwaggerMonoid Operation

948−instance SwaggerMonoid SecurityDefinitions

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

950804

951805instance SwaggerMonoid MimeList

952806deriving instance SwaggerMonoid URL

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

959813 swaggerMempty = ParamQuery

960814 swaggerMappend _ y = y

961815

962−instance OVERLAPPING_ SwaggerMonoid (InsOrdHashMap FilePath PathItem) where

963− swaggerMempty = InsOrdHashMap.empty

964− swaggerMappend = InsOrdHashMap.unionWith mappend

816+instance OVERLAPPING_ SwaggerMonoid (HashMap FilePath PathItem) where

817+ swaggerMempty = HashMap.empty

818+ swaggerMappend = HashMap.unionWith mappend

965819

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

967821 swaggerMempty = Inline mempty

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

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

969823 swaggerMappend _ y = y

970824

971825instance SwaggerMonoid ParamAnySchema where

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

1059913 , "tokenUrl" .= tokenUrl ]

1060914

1061915instance ToJSON OAuth2Params where

1062− toJSON = sopSwaggerGenericToJSON

1063− DEFINE_TOENCODING

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

1064917

1065918instance ToJSON SecuritySchemeType where

1066919 toJSON SecuritySchemeBasic

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

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

1074927

1075928instance ToJSON Swagger where

1076− toJSON = sopSwaggerGenericToJSON

1077− DEFINE_TOENCODING

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

930+ where

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

932+ addVersion _ = error "impossible"

1078933

1079934instance ToJSON SecurityScheme where

1080− toJSON = sopSwaggerGenericToJSON

1081− DEFINE_TOENCODING

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

1082936

1083937instance ToJSON Schema where

1084− toJSON = sopSwaggerGenericToJSON

1085− DEFINE_TOENCODING

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

939+ where

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

941+ f _ _ = False

1086942

1087943instance ToJSON Header where

1088− toJSON = sopSwaggerGenericToJSON

1089− DEFINE_TOENCODING

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

1090945

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

946+instance ToJSON (SwaggerItems t) where

1098947 toJSON (SwaggerItemsPrimitive fmt schema) = object

1099948 [ "collectionFormat" .= fmt

1100949 , "items" .= schema ]

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

1102− toJSON (SwaggerItemsArray []) = object

1103− [ "items" .= object []

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

1105− , "example" .= Array mempty

1106− ]

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

1108952

1109953instance ToJSON Host where

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

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

1117961

1118962instance ToJSON Param where

1119− toJSON = sopSwaggerGenericToJSON

1120− DEFINE_TOENCODING

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

1121964

1122965instance ToJSON ParamAnySchema where

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

1124967 toJSON (ParamOther s) = toJSON s

1125968

1126969instance ToJSON ParamOtherSchema where

1127− toJSON = sopSwaggerGenericToJSON

1128− DEFINE_TOENCODING

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

1129971

1130972instance ToJSON Responses where

1131− toJSON = sopSwaggerGenericToJSON

1132− DEFINE_TOENCODING

973+ toJSON (Responses def rs) = omitEmpties $

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

1133975

1134976instance ToJSON Response where

1135− toJSON = sopSwaggerGenericToJSON

1136− DEFINE_TOENCODING

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

1137978

1138979instance ToJSON Operation where

1139− toJSON = sopSwaggerGenericToJSON

1140− DEFINE_TOENCODING

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

1141981

1142982instance ToJSON PathItem where

1143− toJSON = sopSwaggerGenericToJSON

1144− DEFINE_TOENCODING

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

1145984

1146985instance ToJSON Example where

1147986 toJSON = toJSON . Map.mapKeys show . getExample

1148987

1149−instance ToJSON SecurityDefinitions where

1150− toJSON (SecurityDefinitions sd) = toJSON sd

1151−

1152988instance ToJSON Reference where

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

1154990

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

11771013 toJSON CollectionPipes = "pipes"

11781014 toJSON CollectionMulti = "multi"

11791015

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

1016+instance ToJSON (ParamSchema t) where

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

1018+ where

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

1020+ f _ _ = False

11881021

11891022-- =======================================================================

11901023-- Manual FromJSON instances

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

12041037 parseJSON _ = empty

12051038

12061039instance FromJSON OAuth2Params where

1207− parseJSON = sopSwaggerGenericParseJSON

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

12081041

12091042instance FromJSON SecuritySchemeType where

12101043 parseJSON js@(Object o) = do

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

12171050 parseJSON _ = empty

12181051

12191052instance FromJSON Swagger where

1220− parseJSON = sopSwaggerGenericParseJSON

1053+ parseJSON js@(Object o) = do

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

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

1056+ (genericParseJSON (jsonPrefix "swagger")

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

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

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

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

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

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

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

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

1065+ ] ) js

1066+ parseJSON _ = empty

12211067

12221068instance FromJSON SecurityScheme where

1223− parseJSON = sopSwaggerGenericParseJSON

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

12241070

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

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

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

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

12331075

12341076instance FromJSON Header where

1235− parseJSON = sopSwaggerGenericParseJSON

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

12361078

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

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

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

12391081 <$> o .:? "collectionFormat"

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

12411083

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

1084+instance OVERLAPPABLE_ FromJSON (SwaggerItems Schema) where

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

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

12631087 parseJSON _ = empty

12641088

12651089instance 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 ++ "'"

1090+ parseJSON (String s) =

1091+ case fromInteger <$> readMaybe portStr of

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

1093+ mport -> pure $ Host host mport

1094+ where

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

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

12721097 parseJSON _ = empty

12731098

12741099instance FromJSON MimeList where

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

12761101

12771102instance FromJSON Param where

1278− parseJSON = sopSwaggerGenericParseJSON

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

12791104

12801105instance FromJSON ParamAnySchema where

12811106 parseJSON js@(Object o) = do

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

12881113 parseJSON _ = empty

12891114

12901115instance FromJSON ParamOtherSchema where

1291− parseJSON = sopSwaggerGenericParseJSON

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

12921117

12931118instance FromJSON Responses where

12941119 parseJSON (Object o) = Responses

12951120 <$> o .:? "default"

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

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

12971122 parseJSON _ = empty

12981123

12991124instance FromJSON Example where

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

13021127 pure $ Example (Map.mapKeys fromString m)

13031128

13041129instance FromJSON Response where

1305− parseJSON = sopSwaggerGenericParseJSON

1130+ parseJSON = genericParseJSON (jsonPrefix "response")

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

13061132

13071133instance FromJSON Operation where

1308− parseJSON = sopSwaggerGenericParseJSON

1134+ parseJSON = genericParseJSON (jsonPrefix "operation")

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

13091136

13101137instance FromJSON PathItem where

1311− parseJSON = sopSwaggerGenericParseJSON

1312−

1313−instance FromJSON SecurityDefinitions where

1314− parseJSON js = SecurityDefinitions <$> parseJSON js

1138+ parseJSON = genericParseJSON (jsonPrefix "pathItem")

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

13151140

13161141instance FromJSON Reference where

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

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

13371162instance FromJSON Xml where

13381163 parseJSON = genericParseJSON (jsonPrefix "xml")

13391164

1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where

1165+instance FromJSON (SwaggerType Schema) where

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

13421167

1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where

1168+instance FromJSON (SwaggerType ParamOtherSchema) where

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

13451170

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

1171+instance OVERLAPPABLE_ FromJSON (SwaggerType t) where

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

13481173

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

1174+instance OVERLAPPABLE_ FromJSON (CollectionFormat t) where

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

13511176

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

1177+instance FromJSON (CollectionFormat ParamOtherSchema) where

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

13581179

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

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

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

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

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

1184+-- and primitive array items.

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

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

1187+

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.hs+77−264

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

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE GADTs #-}

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE GADTs #-}

75{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE LambdaCase #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PackageImports #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TemplateHaskell #-}

14−{-# LANGUAGE UndecidableInstances #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE PackageImports #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TemplateHaskell #-}

12+{-# LANGUAGE UndecidableInstances #-}

1513-- |

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

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

2220-- Validate JSON values with Swagger Schema.

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

2422

25−import Prelude ()

26−import Prelude.Compat

23+import Control.Applicative

24+import Control.Lens

25+import Control.Lens.TH

26+import Control.Monad (when)

2727

28−import Control.Applicative

29−import Control.Lens

30−import Control.Monad (when)

31−

32−import Data.Aeson hiding (Result)

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

34−import Data.Foldable (for_, sequenceA_,

35− traverse_)

36−import Data.HashMap.Strict (HashMap)

37−import qualified Data.HashMap.Strict as HashMap

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

28+import Data.Aeson hiding (Result)

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

30+import Data.HashMap.Strict (HashMap)

31+import qualified Data.HashMap.Strict as HashMap

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

40−import Data.Proxy

41−import Data.Scientific (Scientific, isInteger)

42−import Data.Text (Text)

43−import qualified Data.Text as Text

44−import qualified Data.Text.Lazy as TL

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

46−import Data.Vector (Vector)

47−import qualified Data.Vector as Vector

48−

49−import Data.Swagger.Declare

50−import Data.Swagger.Internal

51−import Data.Swagger.Internal.Schema

52−import Data.Swagger.Lens

33+import Data.Monoid

34+import Data.Proxy

35+import Data.Scientific (Scientific, isInteger)

36+import Data.Text (Text)

37+import qualified Data.Text as Text

38+import Data.Vector (Vector)

39+import qualified Data.Vector as Vector

40+

41+import Data.Swagger.Declare

42+import Data.Swagger.Internal

43+import Data.Swagger.Internal.Schema

44+import Data.Swagger.Lens

5345

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

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

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

5850--

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

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

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

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

6955

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

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

7258--

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

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

17163 Failed xs -> xs

17264 Passed _ -> mempty

17365 where

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

67+ js = toJSON x

17468 cfg = defaultConfig

17569 { configPatternChecker = checker

17670 , configDefinitions = defs }

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

19993instance Monad Result where

20094 return = pure

20195 Passed x >>= f = f x

202− Failed xs >>= _ = Failed xs

96+ Failed xs >>= f = Failed xs

20397

20498-- | Validation configuration.

20599data Config = Config

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

244138

245139instance Monad (Validation s) where

246140 return = pure

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

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

248142 (>>) = (*>)

249143

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

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

263157

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

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

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

276−check = checkMissing valid

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

162+ case schema ^. l of

163+ Nothing -> valid

164+ Just x -> g x

277165

278166-- | Validate same value with different schema.

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

@@ -286,12 +174,12 @@ sub_ = lmap . view

286174-- | Validate value against a schema given schema reference and validation function.

287175withRef :: Reference -> (Schema -> Validation s a) -> Validation s a

288176withRef (Reference ref) f = withConfig $ \cfg ->

289− case InsOrdHashMap.lookup ref (configDefinitions cfg) of

177+ case HashMap.lookup ref (configDefinitions cfg) of

290178 Nothing -> invalid $ "unknown schema " ++ show ref

291179 Just s -> f s

292180

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

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

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

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

296184

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

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

313201 validateNumber n

314202

315203validateNumber :: 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

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

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

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

319207

320208 check maximum_ $ \m ->

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

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

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

373261

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

375−validateObject o = withSchema $ \sch ->

376− case sch ^. discriminator of

263+validateObject o = withSchema $ \schema ->

264+ case schema ^. discriminator of

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

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

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

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

392280 where

393281 size = fromIntegral (HashMap.size o)

394282

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

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

399287

400− validateProps = withSchema $ \sch -> do

288+ validateProps = withSchema $ \schema -> do

401289 for_ (HashMap.toList o) $ \(k, v) ->

402290 case v of

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

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

404292 _ ->

405− case InsOrdHashMap.lookup k (sch ^. properties) of

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

293+ case HashMap.lookup k (schema ^. properties) of

294+ Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v

407295 Just s -> validateWithSchemaRef s v

408296

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−

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

418298validateEnum value = do

419299 check enum_ $ \xs ->

420300 when (value `notElem` xs) $

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

422302

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−

470303validateSchemaType :: 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

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

488314

489315validateParamSchemaType :: 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"

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/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+10−27

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

@@ -60,23 +53,19 @@ makePrisms ''Referenced

6053

6154-- ** 'SwaggerItems' prisms

6255

63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]

56+_SwaggerItemsArray :: forall t. (t ~ Schema) => Review (SwaggerItems t) [Referenced Schema]

6457_SwaggerItemsArray

65− = unto (\x -> SwaggerItemsArray x)

66−{- \x -> case x of

58+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of

6759 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

6860 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

6961 SwaggerItemsArray a -> Right a

70−-}

7162

72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

63+_SwaggerItemsObject :: forall t. (t ~ Schema) => Review (SwaggerItems t) (Referenced Schema)

7364_SwaggerItemsObject

74− = unto (\x -> SwaggerItemsObject x)

75−{- \x -> case x of

65+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of

7666 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

7767 SwaggerItemsObject o -> Right o

7868 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

79−-}

8069

8170_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

8271_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

@@ -96,19 +85,13 @@ instance At Responses where at n = responses . at n

9685instance Ixed Operation where ix n = responses . ix n

9786instance At Operation where at n = responses . at n

9887

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

88+instance HasParamSchema NamedSchema (ParamSchema Schema) where paramSchema = schema.paramSchema

10689

10790-- 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_

91+instance HasType Header (SwaggerType Header) where type_ = paramSchema.type_

92+instance HasType Schema (SwaggerType Schema) where type_ = paramSchema.type_

93+instance HasType NamedSchema (SwaggerType Schema) where type_ = paramSchema.type_

94+instance HasType ParamOtherSchema (SwaggerType ParamOtherSchema) where type_ = paramSchema.type_

11295

11396-- HasDefault instances

11497instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

src/Data/Swagger/Operation.hs+24−116

@@ -1,58 +1,19 @@

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

2+module Data.Swagger.Operation where

353

4+import Control.Applicative

5+import Control.Arrow

366import Control.Lens

377import Data.Data.Lens

38−import Data.List.Compat

8+import qualified Data.HashMap.Strict as HashMap

9+import Data.List

3910import Data.Maybe (mapMaybe)

40−import Data.Proxy

41−import qualified Data.Set as Set

42−

11+import Data.Monoid

4312import Data.Swagger.Declare

4413import Data.Swagger.Internal

4514import Data.Swagger.Lens

4615import Data.Swagger.Schema

4716

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−

5617-- | Prepend path piece to all operations of the spec.

5718-- Leading and trailing slashes are trimmed/added automatically.

5819--

@@ -60,8 +21,10 @@ import qualified Data.HashSet.InsOrd as InsOrdHS

6021-- >>> encode $ prependPath "user/{user_id}" api ^. paths

6122-- "{\"/user/{user_id}/info\":{}}"

6223prependPath :: FilePath -> Swagger -> Swagger

63−prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)

24+prependPath path = paths %~ mapKeys (path </>)

6425 where

26+ mapKeys f = HashMap.fromList . map (first f) . HashMap.toList

27+

6528 x </> y = case trim y of

6629 "" -> "/" <> trim x

6730 y' -> "/" <> trim x <> "/" <> y'

@@ -72,6 +35,11 @@ prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)

7235allOperations :: Traversal' Swagger Operation

7336allOperations = paths.traverse.template

7437

38+-- $setup

39+-- >>> import Data.Aeson

40+-- >>> import Data.Proxy

41+-- >>> import Data.Time

42+

7543-- | @'operationsOf' sub@ will traverse only those operations

7644-- that are present in @sub@. Note that @'Operation'@ is determined

7745-- by both path and method.

@@ -80,15 +48,15 @@ allOperations = paths.traverse.template

8048-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]

8149-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

8250-- >>> encode api

83−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"

51+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"

8452-- >>> 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\"}}}}}}"

53+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"

8654operationsOf :: Swagger -> Traversal' Swagger Operation

8755operationsOf sub = paths.itraversed.withIndex.subops

8856 where

8957 -- | Traverse operations that correspond to paths and methods of the sub API.

9058 subops :: Traversal' (FilePath, PathItem) Operation

91− subops f (path, item) = case InsOrdHashMap.lookup path (sub ^. paths) of

59+ subops f (path, item) = case HashMap.lookup path (sub ^. paths) of

9260 Just subitem -> (,) path <$> methodsOf subitem f item

9361 Nothing -> pure (path, item)

9462

@@ -100,71 +68,30 @@ operationsOf sub = paths.itraversed.withIndex.subops

10068 ops = pathItem ^.. template :: [Maybe Operation]

10169 ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops

10270

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−

11171-- | Apply tags to a part of Swagger spec and update the global

11272-- list of tags.

11373applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

11474applyTagsFor ops ts swag = swag

115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))

116− & tags %~ (<> InsOrdHS.fromList ts)

75+ & ops . tags %~ (map _tagName ts ++)

76+ & tags %~ (ts ++)

11777

11878-- | Construct a response with @'Schema'@ while declaring all

11979-- necessary schema definitions.

12080--

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

82+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"

83+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

12484declareResponse proxy = do

12585 s <- declareSchemaRef proxy

12686 return (mempty & schema ?~ s)

12787

128−-- | Set response for all operations.

88+-- | Set response for specified operations.

12989-- This will also update global schema definitions.

13090--

131−-- If the response already exists it will be overwritten.

132−--

133−-- @

134−-- 'setResponse' = 'setResponseFor' 'allOperations'

135−-- @

136−--

137−-- Example:

138−--

13991-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

14092-- >>> 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'@.

93+-- >>> encode $ api & setResponseFor allOperations 200 res

94+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"

16895setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

16996setResponseFor ops code dres swag = swag

17097 & definitions %~ (<> defs)

@@ -172,22 +99,3 @@ setResponseFor ops code dres swag = swag

17299 where

173100 (defs, res) = runDeclare dres mempty

174101

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+5−12

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

11-- |

22-- Module: Data.Swagger.Schema.Validation

4+-- License: BSD3

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

46-- Stability: experimental

57--

@@ -15,18 +17,9 @@ module Data.Swagger.Schema.Validation (

1517 -- $maybe

1618

1719 -- * JSON validation

18−

19− ValidationError,

20−

21− -- ** Using 'ToJSON' and 'ToSchema'

22− validatePrettyToJSON,

2320 validateToJSON,

2421 validateToJSONWithPatternChecker,

25− renderValidationErrors,

26−

27− -- ** Using 'Value' and 'Schema'

28− validateJSON,

29− validateJSONWithPatternChecker,

22+ ValidationError,

3023) where

3124

3225import Data.Swagger.Internal.Schema.Validation

@@ -84,7 +77,7 @@ import Data.Swagger.Internal.Schema.Validation

8477-- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic

8578-- >>> instance ToJSON Person

8679-- >>> instance ToSchema Person

87−-- >>> validateToJSON (Person "Nick" (Just 24))

80+-- >>> validateToJSON (Person "John" (Just 25))

8881-- []

89−-- >>> validateToJSON (Person "Nick" Nothing)

82+-- >>> validateToJSON (Person "John" Nothing)

9083-- []

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

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

@@ -42,10 +27,8 @@ library

4227 Data.Swagger.Declare

4328 Data.Swagger.Lens

4429 Data.Swagger.Operation

45− Data.Swagger.Optics

4630 Data.Swagger.ParamSchema

4731 Data.Swagger.Schema

48− Data.Swagger.Schema.Generator

4932 Data.Swagger.Schema.Validation

5033 Data.Swagger.SchemaOptions

5134

@@ -55,98 +38,56 @@ library

5538 Data.Swagger.Internal.Schema.Validation

5639 Data.Swagger.Internal.ParamSchema

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

41+ build-depends: base >=4.7 && <4.10

42+ , base-compat >=0.6.0 && <0.10

43+ , aeson

44+ , containers

45+ , hashable

46+ , http-media

47+ , lens

48+ , mtl

49+ , network

50+ , scientific

51+ , text

52+ , template-haskell

53+ , time

54+ , transformers

55+ , unordered-containers

56+ , vector

9657 default-language: Haskell2010

9758

9859test-suite spec

9960 type: exitcode-stdio-1.0

10061 hs-source-dirs: test

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

63+ build-depends: base

64+ , base-compat

65+ , aeson

66+ , aeson-qq

67+ , containers

68+ , hashable

69+ , hspec

70+ , HUnit

71+ , mtl

72+ , QuickCheck

73+ , swagger2

74+ , text

75+ , time

76+ , unordered-containers

77+ , vector

78+ , lens

13479 other-modules:

13580 SpecCommon

13681 Data.SwaggerSpec

137− Data.Swagger.CommonTestTypes

138− Data.Swagger.ParamSchemaSpec

13982 Data.Swagger.SchemaSpec

14083 Data.Swagger.Schema.ValidationSpec

141− Data.Swagger.Schema.GeneratorSpec

14284 default-language: Haskell2010

14385

144−test-suite doctests

145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes

146− build-depends: base, doctest, Glob, QuickCheck

86+test-suite doctest

87+ build-depends: base, doctest, Glob

14788 default-language: Haskell2010

14889 hs-source-dirs: test

149− main-is: doctests.hs

90+ main-is: DocTest.hs

15091 type: exitcode-stdio-1.0

15192

15293source-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+65−130

@@ -1,50 +1,43 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE PackageImports #-}

4−{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# OPTIONS_GHC -fno-warn-orphans #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE PackageImports #-}

74module Data.Swagger.Schema.ValidationSpec where

9−import Control.Applicative

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

11−import Data.Aeson

12−import Data.Aeson.Types

13−import Data.Hashable (Hashable)

14−import Data.HashMap.Strict (HashMap)

15−import qualified Data.HashMap.Strict as HashMap

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

6+import Control.Applicative

7+import Data.Aeson

8+import Data.Aeson.Types

9+import Data.Int

10+import Data.IntMap (IntMap)

11+import qualified Data.IntMap as IntMap

12+import Data.IntSet (IntSet)

13+import Data.Hashable (Hashable)

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

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

18−import Data.Int

19−import Data.IntMap (IntMap)

20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

21−import Data.Map (Map, fromList)

22−import Data.Monoid (mempty)

23−import Data.Proxy

24−import Data.Set (Set)

25−import qualified Data.Text as T

26−import qualified Data.Text.Lazy as TL

27−import Data.Time

28−import Data.Version (Version)

29−import Data.Word

30−import GHC.Generics

31−

32−import Data.Swagger

33−import Data.Swagger.Declare

34−

35−import Test.Hspec

36−import Test.Hspec.QuickCheck

37−import Test.QuickCheck

38−import Test.QuickCheck.Instances ()

16+import Data.HashMap.Strict (HashMap)

17+import qualified Data.HashMap.Strict as HashMap

18+import Data.Map (Map)

19+import qualified Data.Map as Map

20+import Data.Proxy

21+import Data.Time

22+import qualified Data.Text as T

23+import qualified Data.Text.Lazy as TL

24+import Data.Set (Set)

25+import qualified Data.Set as Set

26+import Data.Word

27+import GHC.Generics

28+

29+import Data.Swagger

30+import Data.Swagger.Declare

31+import Data.Swagger.Schema.Validation

32+

33+import SpecCommon

34+import Test.Hspec

35+import Test.Hspec.QuickCheck

36+import Test.QuickCheck

3937

4038shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

4139shouldValidate _ x = validateToJSON x == []

4240

43−shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool

44−shouldNotValidate f = not . null . validateJSON defs sch . f

45− where

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

47−

4841spec :: Spec

4942spec = do

5043 describe "Validation" $ do

@@ -73,7 +66,6 @@ spec = do

7366 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

7467 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

7568 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

7769 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

7870 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

7971 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

@@ -83,7 +75,6 @@ spec = do

8375 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

8476 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

8577 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)

8778 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

8879 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

8980 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

@@ -92,16 +83,6 @@ spec = do

9283 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

9384 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

9485 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

95− prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)

96− prop "Version" $ shouldValidate (Proxy :: Proxy Version)

97− prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)

98−

99− describe "invalid cases" $ do

100− prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON

101− prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON

102− prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON

103− prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON

104− prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON

10586

10687main :: IO ()

10788main = hspec spec

@@ -121,13 +102,6 @@ instance ToSchema Person

121102instance Arbitrary Person where

122103 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

123104

124−invalidPersonToJSON :: Person -> Value

125−invalidPersonToJSON Person{..} = object

126− [ T.pack "personName" .= toJSON name

127− , T.pack "personPhone" .= toJSON phone

128− , T.pack "personEmail" .= toJSON email

129− ]

130−

131105-- ========================================================================

132106-- Color (enum)

133107-- ========================================================================

@@ -139,11 +113,6 @@ instance ToSchema Color

139113instance Arbitrary Color where

140114 arbitrary = arbitraryBoundedEnum

141115

142−invalidColorToJSON :: Color -> Value

143−invalidColorToJSON Red = toJSON "red"

144−invalidColorToJSON Green = toJSON "green"

145−invalidColorToJSON Blue = toJSON "blue"

146−

147116-- ========================================================================

148117-- Paint (record with bounded enum property)

149118-- ========================================================================

@@ -157,9 +126,6 @@ instance ToSchema Paint

157126instance Arbitrary Paint where

158127 arbitrary = Paint <$> arbitrary

159128

160−invalidPaintToJSON :: Paint -> Value

161−invalidPaintToJSON = toJSON . color

162−

163129-- ========================================================================

164130-- MyRoseTree (custom datatypeNameModifier)

165131-- ========================================================================

@@ -188,8 +154,7 @@ instance Arbitrary MyRoseTree where

188154

189155data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)

190156

191−instance ToSchema Light where

192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

157+instance ToSchema Light

193158

194159instance ToJSON Light where

195160 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

@@ -201,78 +166,48 @@ instance Arbitrary Light where

201166 , LightColor <$> arbitrary

202167 ]

203168

204−invalidLightToJSON :: Light -> Value

205−invalidLightToJSON = genericToJSON defaultOptions

206−

207−-- ========================================================================

208−-- ButtonImages (bounded enum key mapping)

209−-- ========================================================================

210−

211−data ButtonState = Neutral | Focus | Active | Hover | Disabled

212− deriving (Show, Eq, Ord, Bounded, Enum, Generic)

213−

214−instance ToJSON ButtonState

215−instance ToSchema ButtonState

216−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

217−

218−instance Arbitrary ButtonState where

219− arbitrary = arbitraryBoundedEnum

220−

221−type ImageUrl = T.Text

169+-- Arbitrary instances for common types

222170

223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

224− deriving (Show, Generic)

171+#if MIN_VERSION_QuickCheck(2,8,2)

172+#else

173+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where

174+ arbitrary = Map.fromList <$> arbitrary

225175

226−instance ToJSON ButtonImages where

227− toJSON = toJSON . getButtonImages

176+instance Arbitrary a => Arbitrary (IntMap a) where

177+ arbitrary = IntMap.fromList <$> arbitrary

228178

229−instance ToSchema ButtonImages where

230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

231− declareSchemaBoundedEnumKeyMapping

179+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where

180+ arbitrary = Set.fromList <$> arbitrary

181+#endif

232182

233−invalidButtonImagesToJSON :: ButtonImages -> Value

234−invalidButtonImagesToJSON = genericToJSON defaultOptions

183+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

184+ arbitrary = HashMap.fromList <$> arbitrary

235185

236−instance Arbitrary ButtonImages where

237− arbitrary = ButtonImages <$> arbitrary

186+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where

187+ arbitrary = HashSet.fromList <$> arbitrary

238188

239−-- ========================================================================

240−-- FreeForm (wraps a raw JSON Value)

241−-- ========================================================================

189+instance Arbitrary T.Text where

190+ arbitrary = T.pack <$> arbitrary

242191

243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }

244− deriving (Show, Generic)

192+instance Arbitrary TL.Text where

193+ arbitrary = TL.pack <$> arbitrary

245194

246−instance ToJSON FreeForm where

247− toJSON = toJSON . jsonContent

195+instance Arbitrary Day where

196+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary

248197

249−instance ToSchema FreeForm where

250− declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty

251− & type_ ?~ SwaggerObject

252− & additionalProperties ?~ AdditionalPropertiesAllowed True

253−

254−instance Arbitrary FreeForm where

255− arbitrary = (FreeForm . fromList) <$> genObj

256− where

257− genObj = listOf $ do

258− k <- arbitrary

259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]

260− pure (k, v)

198+instance Arbitrary LocalTime where

199+ arbitrary = LocalTime

200+ <$> arbitrary

201+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))

261202

262203instance Eq ZonedTime where

263204 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

264205

265−-- ========================================================================

266−-- Arbitrary instance for Data.Aeson.Value

267−-- ========================================================================

206+instance Arbitrary ZonedTime where

207+ arbitrary = ZonedTime

208+ <$> arbitrary

209+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))

210+

211+instance Arbitrary UTCTime where

212+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))

268213

269−instance Arbitrary Value where

270− -- Weights are almost random

271− -- Uniform oneof tends not to build complex objects cause of recursive call.

272− arbitrary = resize 4 $ frequency

273− [ (3, Object <$> arbitrary)

274− , (3, Array <$> arbitrary)

275− , (3, String <$> arbitrary)

276− , (3, Number <$> arbitrary)

277− , (3, Bool <$> arbitrary)

278− , (1, return Null) ]

test/Data/Swagger/SchemaSpec.hs+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+325−420

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

@@ -128,7 +116,7 @@ licenseExampleJSON = [aesonQQ|

128116

129117operationExample :: Operation

130118operationExample = mempty

131− & tags .~ InsOrdHS.fromList ["pet"]

119+ & tags .~ ["pet"]

132120 & summary ?~ "Updates a pet in the store with form data"

133121 & description ?~ ""

134122 & operationId ?~ "updatePetWithForm"

@@ -159,7 +147,7 @@ operationExample = mempty

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

@@ -551,18 +486,18 @@ swaggerExample = mempty

551486 & at 200 ?~ Inline (mempty

552487 & description .~ "OK"

553488 & schema ?~ Inline (mempty

554− & type_ ?~ SwaggerObject

489+ & type_ .~ SwaggerObject

555490 & example ?~ [aesonQQ|

556491 {

557492 "created": 100,

558493 "description": "get milk"

559494 } |]

560− & description ?~ "This is some real Todo right here"

495+ & description ?~ "This is some real Todo right here"

561496 & properties .~

562497 [ ("created", Inline $ mempty

563− & type_ ?~ SwaggerInteger

498+ & type_ .~ SwaggerInteger

564499 & format ?~ "int32")

565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))

500+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))

566501 & produces ?~ MimeList [ "application/json" ]

567502 & parameters .~

568503 [ Inline $ mempty

@@ -571,8 +506,8 @@ swaggerExample = mempty

571506 & description ?~ "TodoId param"

572507 & schema .~ ParamOther (mempty

573508 & in_ .~ ParamPath

574− & type_ ?~ SwaggerString ) ]

575− & tags .~ InsOrdHS.fromList [ "todo" ] ))

509+ & type_ .~ SwaggerString ) ]

510+ & tags .~ [ "todo" ] ))

576511

577512swaggerExampleJSON :: Value

578513swaggerExampleJSON = [aesonQQ|

@@ -639,130 +574,130 @@ swaggerExampleJSON = [aesonQQ|

639574

640575petstoreExampleJSON :: Value

641576petstoreExampleJSON = [aesonQQ|

642−{

577+{

643578 "swagger":"2.0",

644− "info":{

579+ "info":{

645580 "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.",

646581 "version":"1.0.0",

647582 "title":"Swagger Petstore",

648583 "termsOfService":"http://swagger.io/terms/",

649− "contact":{

584+ "contact":{

650585 "email":"apiteam@swagger.io"

651586 },

652− "license":{

587+ "license":{

653588 "name":"Apache 2.0",

654589 "url":"http://www.apache.org/licenses/LICENSE-2.0.html"

655590 }

656591 },

657592 "host":"petstore.swagger.io",

658593 "basePath":"/v2",

659− "tags":[

660− {

594+ "tags":[

595+ {

661596 "name":"pet",

662597 "description":"Everything about your Pets",

663− "externalDocs":{

598+ "externalDocs":{

664599 "description":"Find out more",

665600 "url":"http://swagger.io"

666601 }

667602 },

668− {

603+ {

669604 "name":"store",

670605 "description":"Access to Petstore orders"

671606 },

672− {

607+ {

673608 "name":"user",

674609 "description":"Operations about user",

675− "externalDocs":{

610+ "externalDocs":{

676611 "description":"Find out more about our store",

677612 "url":"http://swagger.io"

678613 }

679614 }

680615 ],

681− "schemes":[

616+ "schemes":[

682617 "http"

683618 ],

684− "paths":{

685− "/pet":{

686− "post":{

687− "tags":[

619+ "paths":{

620+ "/pet":{

621+ "post":{

622+ "tags":[

688623 "pet"

689624 ],

690625 "summary":"Add a new pet to the store",

691626 "description":"",

692627 "operationId":"addPet",

693− "consumes":[

628+ "consumes":[

694629 "application/json",

695630 "application/xml"

696631 ],

697− "produces":[

632+ "produces":[

698633 "application/xml",

699634 "application/json"

700635 ],

701− "parameters":[

702− {

636+ "parameters":[

637+ {

703638 "in":"body",

704639 "name":"body",

705640 "description":"Pet object that needs to be added to the store",

706641 "required":true,

707− "schema":{

642+ "schema":{

708643 "$ref":"#/definitions/Pet"

709644 }

710645 }

711646 ],

712− "responses":{

713− "405":{

647+ "responses":{

648+ "405":{

714649 "description":"Invalid input"

715650 }

716651 },

717− "security":[

718− {

719− "petstore_auth":[

652+ "security":[

653+ {

654+ "petstore_auth":[

720655 "write:pets",

721656 "read:pets"

722657 ]

723658 }

724659 ]

725660 },

726− "put":{

727− "tags":[

661+ "put":{

662+ "tags":[

728663 "pet"

729664 ],

730665 "summary":"Update an existing pet",

731666 "description":"",

732667 "operationId":"updatePet",

733− "consumes":[

668+ "consumes":[

734669 "application/json",

735670 "application/xml"

736671 ],

737− "produces":[

672+ "produces":[

738673 "application/xml",

739674 "application/json"

740675 ],

741− "parameters":[

742− {

676+ "parameters":[

677+ {

743678 "in":"body",

744679 "name":"body",

745680 "description":"Pet object that needs to be added to the store",

746681 "required":true,

747− "schema":{

682+ "schema":{

748683 "$ref":"#/definitions/Pet"

749684 }

750685 }

751686 ],

752− "responses":{

753− "400":{

687+ "responses":{

688+ "400":{

754689 "description":"Invalid ID supplied"

755690 },

756− "404":{

691+ "404":{

757692 "description":"Pet not found"

758693 },

759− "405":{

694+ "405":{

760695 "description":"Validation exception"

761696 }

762697 },

763− "security":[

764− {

765− "petstore_auth":[

698+ "security":[

699+ {

700+ "petstore_auth":[

766701 "write:pets",

767702 "read:pets"

768703 ]

@@ -770,28 +705,28 @@ petstoreExampleJSON = [aesonQQ|

770705 ]

771706 }

772707 },

773− "/pet/findByStatus":{

774− "get":{

775− "tags":[

708+ "/pet/findByStatus":{

709+ "get":{

710+ "tags":[

776711 "pet"

777712 ],

778713 "summary":"Finds Pets by status",

779714 "description":"Multiple status values can be provided with comma seperated strings",

780715 "operationId":"findPetsByStatus",

781− "produces":[

716+ "produces":[

782717 "application/xml",

783718 "application/json"

784719 ],

785− "parameters":[

786− {

720+ "parameters":[

721+ {

787722 "name":"status",

788723 "in":"query",

789724 "description":"Status values that need to be considered for filter",

790725 "required":true,

791726 "type":"array",

792− "items":{

727+ "items":{

793728 "type":"string",

794− "enum":[

729+ "enum":[

795730 "available",

796731 "pending",

797732 "sold"

@@ -801,23 +736,23 @@ petstoreExampleJSON = [aesonQQ|

801736 "collectionFormat":"csv"

802737 }

803738 ],

804− "responses":{

805− "200":{

739+ "responses":{

740+ "200":{

806741 "description":"successful operation",

807− "schema":{

742+ "schema":{

808743 "type":"array",

809− "items":{

744+ "items":{

810745 "$ref":"#/definitions/Pet"

811746 }

812747 }

813748 },

814− "400":{

749+ "400":{

815750 "description":"Invalid status value"

816751 }

817752 },

818− "security":[

819− {

820− "petstore_auth":[

753+ "security":[

754+ {

755+ "petstore_auth":[

821756 "write:pets",

822757 "read:pets"

823758 ]

@@ -825,48 +760,48 @@ petstoreExampleJSON = [aesonQQ|

825760 ]

826761 }

827762 },

828− "/pet/findByTags":{

829− "get":{

830− "tags":[

763+ "/pet/findByTags":{

764+ "get":{

765+ "tags":[

831766 "pet"

832767 ],

833768 "summary":"Finds Pets by tags",

834769 "description":"Muliple tags can be provided with comma seperated strings. Use tag1, tag2, tag3 for testing.",

835770 "operationId":"findPetsByTags",

836− "produces":[

771+ "produces":[

837772 "application/xml",

838773 "application/json"

839774 ],

840− "parameters":[

841− {

775+ "parameters":[

776+ {

842777 "name":"tags",

843778 "in":"query",

844779 "description":"Tags to filter by",

845780 "required":true,

846781 "type":"array",

847− "items":{

782+ "items":{

848783 "type":"string"

849784 },

850785 "collectionFormat":"csv"

851786 }

852787 ],

853− "responses":{

854− "200":{

788+ "responses":{

789+ "200":{

855790 "description":"successful operation",

856− "schema":{

791+ "schema":{

857792 "type":"array",

858− "items":{

793+ "items":{

859794 "$ref":"#/definitions/Pet"

860795 }

861796 }

862797 },

863− "400":{

798+ "400":{

864799 "description":"Invalid tag value"

865800 }

866801 },

867− "security":[

868− {

869− "petstore_auth":[

802+ "security":[

803+ {

804+ "petstore_auth":[

870805 "write:pets",

871806 "read:pets"

872807 ]

@@ -874,20 +809,20 @@ petstoreExampleJSON = [aesonQQ|

874809 ]

875810 }

876811 },

877− "/pet/{petId}":{

878− "get":{

879− "tags":[

812+ "/pet/{petId}":{

813+ "get":{

814+ "tags":[

880815 "pet"

881816 ],

882817 "summary":"Find pet by ID",

883818 "description":"Returns a single pet",

884819 "operationId":"getPetById",

885− "produces":[

820+ "produces":[

886821 "application/xml",

887822 "application/json"

888823 ],

889− "parameters":[

890− {

824+ "parameters":[

825+ {

891826 "name":"petId",

892827 "in":"path",

893828 "description":"ID of pet to return",

@@ -896,42 +831,42 @@ petstoreExampleJSON = [aesonQQ|

896831 "format":"int64"

897832 }

898833 ],

899− "responses":{

900− "200":{

834+ "responses":{

835+ "200":{

901836 "description":"successful operation",

902− "schema":{

837+ "schema":{

903838 "$ref":"#/definitions/Pet"

904839 }

905840 },

906− "400":{

841+ "400":{

907842 "description":"Invalid ID supplied"

908843 },

909− "404":{

844+ "404":{

910845 "description":"Pet not found"

911846 }

912847 },

913− "security":[

914− {

848+ "security":[

849+ {

915850 "api_key": []

916851 }

917852 ]

918853 },

919− "post":{

920− "tags":[

854+ "post":{

855+ "tags":[

921856 "pet"

922857 ],

923858 "summary":"Updates a pet in the store with form data",

924859 "description":"",

925860 "operationId":"updatePetWithForm",

926− "consumes":[

861+ "consumes":[

927862 "application/x-www-form-urlencoded"

928863 ],

929− "produces":[

864+ "produces":[

930865 "application/xml",

931866 "application/json"

932867 ],

933− "parameters":[

934− {

868+ "parameters":[

869+ {

935870 "name":"petId",

936871 "in":"path",

937872 "description":"ID of pet that needs to be updated",

@@ -939,14 +874,14 @@ petstoreExampleJSON = [aesonQQ|

939874 "type":"integer",

940875 "format":"int64"

941876 },

942− {

877+ {

943878 "name":"name",

944879 "in":"formData",

945880 "description":"Updated name of the pet",

946881 "required":false,

947882 "type":"string"

948883 },

949− {

884+ {

950885 "name":"status",

951886 "in":"formData",

952887 "description":"Updated status of the pet",

@@ -954,39 +889,39 @@ petstoreExampleJSON = [aesonQQ|

954889 "type":"string"

955890 }

956891 ],

957− "responses":{

958− "405":{

892+ "responses":{

893+ "405":{

959894 "description":"Invalid input"

960895 }

961896 },

962− "security":[

963− {

964− "petstore_auth":[

897+ "security":[

898+ {

899+ "petstore_auth":[

965900 "write:pets",

966901 "read:pets"

967902 ]

968903 }

969904 ]

970905 },

971− "delete":{

972− "tags":[

906+ "delete":{

907+ "tags":[

973908 "pet"

974909 ],

975910 "summary":"Deletes a pet",

976911 "description":"",

977912 "operationId":"deletePet",

978− "produces":[

913+ "produces":[

979914 "application/xml",

980915 "application/json"

981916 ],

982− "parameters":[

983− {

917+ "parameters":[

918+ {

984919 "name":"api_key",

985920 "in":"header",

986921 "required":false,

987922 "type":"string"

988923 },

989− {

924+ {

990925 "name":"petId",

991926 "in":"path",

992927 "description":"Pet id to delete",

@@ -995,14 +930,14 @@ petstoreExampleJSON = [aesonQQ|

995930 "format":"int64"

996931 }

997932 ],

998− "responses":{

999− "400":{

933+ "responses":{

934+ "400":{

1000935 "description":"Invalid pet value"

1001936 }

1002937 },

1003− "security":[

1004− {

1005− "petstore_auth":[

938+ "security":[

939+ {

940+ "petstore_auth":[

1006941 "write:pets",

1007942 "read:pets"

1008943 ]

@@ -1010,22 +945,22 @@ petstoreExampleJSON = [aesonQQ|

1010945 ]

1011946 }

1012947 },

1013− "/pet/{petId}/uploadImage":{

1014− "post":{

1015− "tags":[

948+ "/pet/{petId}/uploadImage":{

949+ "post":{

950+ "tags":[

1016951 "pet"

1017952 ],

1018953 "summary":"uploads an image",

1019954 "description":"",

1020955 "operationId":"uploadFile",

1021− "consumes":[

956+ "consumes":[

1022957 "multipart/form-data"

1023958 ],

1024− "produces":[

959+ "produces":[

1025960 "application/json"

1026961 ],

1027− "parameters":[

1028− {

962+ "parameters":[

963+ {

1029964 "name":"petId",

1030965 "in":"path",

1031966 "description":"ID of pet to update",

@@ -1033,14 +968,14 @@ petstoreExampleJSON = [aesonQQ|

1033968 "type":"integer",

1034969 "format":"int64"

1035970 },

1036− {

971+ {

1037972 "name":"additionalMetadata",

1038973 "in":"formData",

1039974 "description":"Additional data to pass to server",

1040975 "required":false,

1041976 "type":"string"

1042977 },

1043− {

978+ {

1044979 "name":"file",

1045980 "in":"formData",

1046981 "description":"file to upload",

@@ -1048,17 +983,17 @@ petstoreExampleJSON = [aesonQQ|

1048983 "type":"file"

1049984 }

1050985 ],

1051− "responses":{

1052− "200":{

986+ "responses":{

987+ "200":{

1053988 "description":"successful operation",

1054− "schema":{

989+ "schema":{

1055990 "$ref":"#/definitions/ApiResponse"

1056991 }

1057992 }

1058993 },

1059− "security":[

1060− {

1061− "petstore_auth":[

994+ "security":[

995+ {

996+ "petstore_auth":[

1062997 "write:pets",

1063998 "read:pets"

1064999 ]

@@ -1066,87 +1001,87 @@ petstoreExampleJSON = [aesonQQ|

10661001 ]

10671002 }

10681003 },

1069− "/store/inventory":{

1070− "get":{

1071− "tags":[

1004+ "/store/inventory":{

1005+ "get":{

1006+ "tags":[

10721007 "store"

10731008 ],

10741009 "summary":"Returns pet inventories by status",

10751010 "description":"Returns a map of status codes to quantities",

10761011 "operationId":"getInventory",

1077− "produces":[

1012+ "produces":[

10781013 "application/json"

10791014 ],

10801015 "parameters": [],

1081− "responses":{

1082− "200":{

1016+ "responses":{

1017+ "200":{

10831018 "description":"successful operation",

1084− "schema":{

1019+ "schema":{

10851020 "type":"object",

1086− "additionalProperties":{

1021+ "additionalProperties":{

10871022 "type":"integer",

10881023 "format":"int32"

10891024 }

10901025 }

10911026 }

10921027 },

1093− "security":[

1094− {

1028+ "security":[

1029+ {

10951030 "api_key": []

10961031 }

10971032 ]

10981033 }

10991034 },

1100− "/store/order":{

1101− "post":{

1102− "tags":[

1035+ "/store/order":{

1036+ "post":{

1037+ "tags":[

11031038 "store"

11041039 ],

11051040 "summary":"Place an order for a pet",

11061041 "description":"",

11071042 "operationId":"placeOrder",

1108− "produces":[

1043+ "produces":[

11091044 "application/xml",

11101045 "application/json"

11111046 ],

1112− "parameters":[

1113− {

1047+ "parameters":[

1048+ {

11141049 "in":"body",

11151050 "name":"body",

11161051 "description":"order placed for purchasing the pet",

11171052 "required":true,

1118− "schema":{

1053+ "schema":{

11191054 "$ref":"#/definitions/Order"

11201055 }

11211056 }

11221057 ],

1123− "responses":{

1124− "200":{

1058+ "responses":{

1059+ "200":{

11251060 "description":"successful operation",

1126− "schema":{

1061+ "schema":{

11271062 "$ref":"#/definitions/Order"

11281063 }

11291064 },

1130− "400":{

1065+ "400":{

11311066 "description":"Invalid Order"

11321067 }

11331068 }

11341069 }

11351070 },

1136− "/store/order/{orderId}":{

1137− "get":{

1138− "tags":[

1071+ "/store/order/{orderId}":{

1072+ "get":{

1073+ "tags":[

11391074 "store"

11401075 ],

11411076 "summary":"Find purchase order by ID",

11421077 "description":"For valid response try integer IDs with value <= 5 or > 10. Other values will generated exceptions",

11431078 "operationId":"getOrderById",

1144− "produces":[

1079+ "produces":[

11451080 "application/xml",

11461081 "application/json"

11471082 ],

1148− "parameters":[

1149− {

1083+ "parameters":[

1084+ {

11501085 "name":"orderId",

11511086 "in":"path",

11521087 "description":"ID of pet that needs to be fetched",

@@ -1157,34 +1092,34 @@ petstoreExampleJSON = [aesonQQ|

11571092 "format":"int64"

11581093 }

11591094 ],

1160− "responses":{

1161− "200":{

1095+ "responses":{

1096+ "200":{

11621097 "description":"successful operation",

1163− "schema":{

1098+ "schema":{

11641099 "$ref":"#/definitions/Order"

11651100 }

11661101 },

1167− "400":{

1102+ "400":{

11681103 "description":"Invalid ID supplied"

11691104 },

1170− "404":{

1105+ "404":{

11711106 "description":"Order not found"

11721107 }

11731108 }

11741109 },

1175− "delete":{

1176− "tags":[

1110+ "delete":{

1111+ "tags":[

11771112 "store"

11781113 ],

11791114 "summary":"Delete purchase order by ID",

11801115 "description":"For valid response try integer IDs with value < 1000. Anything above 1000 or nonintegers will generate API errors",

11811116 "operationId":"deleteOrder",

1182− "produces":[

1117+ "produces":[

11831118 "application/xml",

11841119 "application/json"

11851120 ],

1186− "parameters":[

1187− {

1121+ "parameters":[

1122+ {

11881123 "name":"orderId",

11891124 "in":"path",

11901125 "description":"ID of the order that needs to be deleted",

@@ -1193,133 +1128,133 @@ petstoreExampleJSON = [aesonQQ|

11931128 "minimum":1.0

11941129 }

11951130 ],

1196− "responses":{

1197− "400":{

1131+ "responses":{

1132+ "400":{

11981133 "description":"Invalid ID supplied"

11991134 },

1200− "404":{

1135+ "404":{

12011136 "description":"Order not found"

12021137 }

12031138 }

12041139 }

12051140 },

1206− "/user":{

1207− "post":{

1208− "tags":[

1141+ "/user":{

1142+ "post":{

1143+ "tags":[

12091144 "user"

12101145 ],

12111146 "summary":"Create user",

12121147 "description":"This can only be done by the logged in user.",

12131148 "operationId":"createUser",

1214− "produces":[

1149+ "produces":[

12151150 "application/xml",

12161151 "application/json"

12171152 ],

1218− "parameters":[

1219− {

1153+ "parameters":[

1154+ {

12201155 "in":"body",

12211156 "name":"body",

12221157 "description":"Created user object",

12231158 "required":true,

1224− "schema":{

1159+ "schema":{

12251160 "$ref":"#/definitions/User"

12261161 }

12271162 }

12281163 ],

1229− "responses":{

1230− "default":{

1164+ "responses":{

1165+ "default":{

12311166 "description":"successful operation"

12321167 }

12331168 }

12341169 }

12351170 },

1236− "/user/createWithArray":{

1237− "post":{

1238− "tags":[

1171+ "/user/createWithArray":{

1172+ "post":{

1173+ "tags":[

12391174 "user"

12401175 ],

12411176 "summary":"Creates list of users with given input array",

12421177 "description":"",

12431178 "operationId":"createUsersWithArrayInput",

1244− "produces":[

1179+ "produces":[

12451180 "application/xml",

12461181 "application/json"

12471182 ],

1248− "parameters":[

1249− {

1183+ "parameters":[

1184+ {

12501185 "in":"body",

12511186 "name":"body",

12521187 "description":"List of user object",

12531188 "required":true,

1254− "schema":{

1189+ "schema":{

12551190 "type":"array",

1256− "items":{

1191+ "items":{

12571192 "$ref":"#/definitions/User"

12581193 }

12591194 }

12601195 }

12611196 ],

1262− "responses":{

1263− "default":{

1197+ "responses":{

1198+ "default":{

12641199 "description":"successful operation"

12651200 }

12661201 }

12671202 }

12681203 },

1269− "/user/createWithList":{

1270− "post":{

1271− "tags":[

1204+ "/user/createWithList":{

1205+ "post":{

1206+ "tags":[

12721207 "user"

12731208 ],

12741209 "summary":"Creates list of users with given input array",

12751210 "description":"",

12761211 "operationId":"createUsersWithListInput",

1277− "produces":[

1212+ "produces":[

12781213 "application/xml",

12791214 "application/json"

12801215 ],

1281− "parameters":[

1282− {

1216+ "parameters":[

1217+ {

12831218 "in":"body",

12841219 "name":"body",

12851220 "description":"List of user object",

12861221 "required":true,

1287− "schema":{

1222+ "schema":{

12881223 "type":"array",

1289− "items":{

1224+ "items":{

12901225 "$ref":"#/definitions/User"

12911226 }

12921227 }

12931228 }

12941229 ],

1295− "responses":{

1296− "default":{

1230+ "responses":{

1231+ "default":{

12971232 "description":"successful operation"

12981233 }

12991234 }

13001235 }

13011236 },

1302− "/user/login":{

1303− "get":{

1304− "tags":[

1237+ "/user/login":{

1238+ "get":{

1239+ "tags":[

13051240 "user"

13061241 ],

13071242 "summary":"Logs user into the system",

13081243 "description":"",

13091244 "operationId":"loginUser",

1310− "produces":[

1245+ "produces":[

13111246 "application/xml",

13121247 "application/json"

13131248 ],

1314− "parameters":[

1315− {

1249+ "parameters":[

1250+ {

13161251 "name":"username",

13171252 "in":"query",

13181253 "description":"The user name for login",

13191254 "required":true,

13201255 "type":"string"

13211256 },

1322− {

1257+ {

13231258 "name":"password",

13241259 "in":"query",

13251260 "description":"The password for login in clear text",

@@ -1327,65 +1262,65 @@ petstoreExampleJSON = [aesonQQ|

13271262 "type":"string"

13281263 }

13291264 ],

1330− "responses":{

1331− "200":{

1265+ "responses":{

1266+ "200":{

13321267 "description":"successful operation",

1333− "schema":{

1268+ "schema":{

13341269 "type":"string"

13351270 },

1336− "headers":{

1337− "X-Rate-Limit":{

1271+ "headers":{

1272+ "X-Rate-Limit":{

13381273 "type":"integer",

13391274 "format":"int32",

13401275 "description":"calls per hour allowed by the user"

13411276 },

1342− "X-Expires-After":{

1277+ "X-Expires-After":{

13431278 "type":"string",

13441279 "format":"date-time",

13451280 "description":"date in UTC when toekn expires"

13461281 }

13471282 }

13481283 },

1349− "400":{

1284+ "400":{

13501285 "description":"Invalid username/password supplied"

13511286 }

13521287 }

13531288 }

13541289 },

1355− "/user/logout":{

1356− "get":{

1357− "tags":[

1290+ "/user/logout":{

1291+ "get":{

1292+ "tags":[

13581293 "user"

13591294 ],

13601295 "summary":"Logs out current logged in user session",

13611296 "description":"",

13621297 "operationId":"logoutUser",

1363− "produces":[

1298+ "produces":[

13641299 "application/xml",

13651300 "application/json"

13661301 ],

13671302 "parameters": [],

1368− "responses":{

1369− "default":{

1303+ "responses":{

1304+ "default":{

13701305 "description":"successful operation"

13711306 }

13721307 }

13731308 }

13741309 },

1375− "/user/{username}":{

1376− "get":{

1377− "tags":[

1310+ "/user/{username}":{

1311+ "get":{

1312+ "tags":[

13781313 "user"

13791314 ],

13801315 "summary":"Get user by user name",

13811316 "description":"",

13821317 "operationId":"getUserByName",

1383− "produces":[

1318+ "produces":[

13841319 "application/xml",

13851320 "application/json"

13861321 ],

1387− "parameters":[

1388− {

1322+ "parameters":[

1323+ {

13891324 "name":"username",

13901325 "in":"path",

13911326 "description":"The name that needs to be fetched. Use user1 for testing. ",

@@ -1393,72 +1328,72 @@ petstoreExampleJSON = [aesonQQ|

13931328 "type":"string"

13941329 }

13951330 ],

1396− "responses":{

1397− "200":{

1331+ "responses":{

1332+ "200":{

13981333 "description":"successful operation",

1399− "schema":{

1334+ "schema":{

14001335 "$ref":"#/definitions/User"

14011336 }

14021337 },

1403− "400":{

1338+ "400":{

14041339 "description":"Invalid username supplied"

14051340 },

1406− "404":{

1341+ "404":{

14071342 "description":"User not found"

14081343 }

14091344 }

14101345 },

1411− "put":{

1412− "tags":[

1346+ "put":{

1347+ "tags":[

14131348 "user"

14141349 ],

14151350 "summary":"Updated user",

14161351 "description":"This can only be done by the logged in user.",

14171352 "operationId":"updateUser",

1418− "produces":[

1353+ "produces":[

14191354 "application/xml",

14201355 "application/json"

14211356 ],

1422− "parameters":[

1423− {

1357+ "parameters":[

1358+ {

14241359 "name":"username",

14251360 "in":"path",

14261361 "description":"name that need to be deleted",

14271362 "required":true,

14281363 "type":"string"

14291364 },

1430− {

1365+ {

14311366 "in":"body",

14321367 "name":"body",

14331368 "description":"Updated user object",

14341369 "required":true,

1435− "schema":{

1370+ "schema":{

14361371 "$ref":"#/definitions/User"

14371372 }

14381373 }

14391374 ],

1440− "responses":{

1441− "400":{

1375+ "responses":{

1376+ "400":{

14421377 "description":"Invalid user supplied"

14431378 },

1444− "404":{

1379+ "404":{

14451380 "description":"User not found"

14461381 }

14471382 }

14481383 },

1449− "delete":{

1450− "tags":[

1384+ "delete":{

1385+ "tags":[

14511386 "user"

14521387 ],

14531388 "summary":"Delete user",

14541389 "description":"This can only be done by the logged in user.",

14551390 "operationId":"deleteUser",

1456− "produces":[

1391+ "produces":[

14571392 "application/xml",

14581393 "application/json"

14591394 ],

1460− "parameters":[

1461− {

1395+ "parameters":[

1396+ {

14621397 "name":"username",

14631398 "in":"path",

14641399 "description":"The name that needs to be deleted",

@@ -1466,237 +1401,207 @@ petstoreExampleJSON = [aesonQQ|

14661401 "type":"string"

14671402 }

14681403 ],

1469− "responses":{

1470− "400":{

1404+ "responses":{

1405+ "400":{

14711406 "description":"Invalid username supplied"

14721407 },

1473− "404":{

1408+ "404":{

14741409 "description":"User not found"

14751410 }

14761411 }

14771412 }

14781413 }

14791414 },

1480− "securityDefinitions":{

1481− "petstore_auth":{

1415+ "securityDefinitions":{

1416+ "petstore_auth":{

14821417 "type":"oauth2",

14831418 "authorizationUrl":"http://petstore.swagger.io/api/oauth/dialog",

14841419 "flow":"implicit",

1485− "scopes":{

1420+ "scopes":{

14861421 "write:pets":"modify pets in your account",

14871422 "read:pets":"read your pets"

14881423 }

14891424 },

1490− "api_key":{

1425+ "api_key":{

14911426 "type":"apiKey",

14921427 "name":"api_key",

14931428 "in":"header"

14941429 }

14951430 },

1496− "definitions":{

1497− "Order":{

1431+ "definitions":{

1432+ "Order":{

14981433 "type":"object",

1499− "properties":{

1500− "id":{

1434+ "properties":{

1435+ "id":{

15011436 "type":"integer",

15021437 "format":"int64"

15031438 },

1504− "petId":{

1439+ "petId":{

15051440 "type":"integer",

15061441 "format":"int64"

15071442 },

1508− "quantity":{

1443+ "quantity":{

15091444 "type":"integer",

15101445 "format":"int32"

15111446 },

1512− "shipDate":{

1447+ "shipDate":{

15131448 "type":"string",

15141449 "format":"date-time"

15151450 },

1516− "status":{

1451+ "status":{

15171452 "type":"string",

15181453 "description":"Order Status",

1519− "enum":[

1454+ "enum":[

15201455 "placed",

15211456 "approved",

15221457 "delivered"

15231458 ]

15241459 },

1525− "complete":{

1460+ "complete":{

15261461 "type":"boolean",

15271462 "default":false

15281463 }

15291464 },

1530− "xml":{

1465+ "xml":{

15311466 "name":"Order"

15321467 }

15331468 },

1534− "Category":{

1469+ "Category":{

15351470 "type":"object",

1536− "properties":{

1537− "id":{

1471+ "properties":{

1472+ "id":{

15381473 "type":"integer",

15391474 "format":"int64"

15401475 },

1541− "name":{

1476+ "name":{

15421477 "type":"string"

15431478 }

15441479 },

1545− "xml":{

1480+ "xml":{

15461481 "name":"Category"

15471482 }

15481483 },

1549− "User":{

1484+ "User":{

15501485 "type":"object",

1551− "properties":{

1552− "id":{

1486+ "properties":{

1487+ "id":{

15531488 "type":"integer",

15541489 "format":"int64"

15551490 },

1556− "username":{

1491+ "username":{

15571492 "type":"string"

15581493 },

1559− "firstName":{

1494+ "firstName":{

15601495 "type":"string"

15611496 },

1562− "lastName":{

1497+ "lastName":{

15631498 "type":"string"

15641499 },

1565− "email":{

1500+ "email":{

15661501 "type":"string"

15671502 },

1568− "password":{

1503+ "password":{

15691504 "type":"string"

15701505 },

1571− "phone":{

1506+ "phone":{

15721507 "type":"string"

15731508 },

1574− "userStatus":{

1509+ "userStatus":{

15751510 "type":"integer",

15761511 "format":"int32",

15771512 "description":"User Status"

15781513 }

15791514 },

1580− "xml":{

1515+ "xml":{

15811516 "name":"User"

15821517 }

15831518 },

1584− "Tag":{

1519+ "Tag":{

15851520 "type":"object",

1586− "properties":{

1587− "id":{

1521+ "properties":{

1522+ "id":{

15881523 "type":"integer",

15891524 "format":"int64"

15901525 },

1591− "name":{

1526+ "name":{

15921527 "type":"string"

15931528 }

15941529 },

1595− "xml":{

1530+ "xml":{

15961531 "name":"Tag"

15971532 }

15981533 },

1599− "Pet":{

1534+ "Pet":{

16001535 "type":"object",

1601− "required":[

1536+ "required":[

16021537 "name",

16031538 "photoUrls"

16041539 ],

1605− "properties":{

1606− "id":{

1540+ "properties":{

1541+ "id":{

16071542 "type":"integer",

16081543 "format":"int64"

16091544 },

1610− "category":{

1545+ "category":{

16111546 "$ref":"#/definitions/Category"

16121547 },

1613− "name":{

1548+ "name":{

16141549 "type":"string",

16151550 "example":"doggie"

16161551 },

1617− "photoUrls":{

1552+ "photoUrls":{

16181553 "type":"array",

1619− "xml":{

1554+ "xml":{

16201555 "name":"photoUrl",

16211556 "wrapped":true

16221557 },

1623− "items":{

1558+ "items":{

16241559 "type":"string"

16251560 }

16261561 },

1627− "tags":{

1562+ "tags":{

16281563 "type":"array",

1629− "xml":{

1564+ "xml":{

16301565 "name":"tag",

16311566 "wrapped":true

16321567 },

1633− "items":{

1568+ "items":{

16341569 "$ref":"#/definitions/Tag"

16351570 }

16361571 },

1637− "status":{

1572+ "status":{

16381573 "type":"string",

16391574 "description":"pet status in the store",

1640− "enum":[

1575+ "enum":[

16411576 "available",

16421577 "pending",

16431578 "sold"

16441579 ]

16451580 }

16461581 },

1647− "xml":{

1582+ "xml":{

16481583 "name":"Pet"

16491584 }

16501585 },

1651− "ApiResponse":{

1586+ "ApiResponse":{

16521587 "type":"object",

1653− "properties":{

1654− "code":{

1588+ "properties":{

1589+ "code":{

16551590 "type":"integer",

16561591 "format":"int32"

16571592 },

1658− "type":{

1593+ "type":{

16591594 "type":"string"

16601595 },

1661− "message":{

1596+ "message":{

16621597 "type":"string"

16631598 }

16641599 }

16651600 }

16661601 },

1667− "externalDocs":{

1602+ "externalDocs":{

16681603 "description":"Find out more about Swagger",

16691604 "url":"http://swagger.io"

16701605 }

16711606}

16721607|]

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