47e7fdf...master · typeable/swagger2

git.iko.soy/typeable/swagger2

.ghci+1

since splitsnapshots

@@ -1 +1,2 @@

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

.travis.yml+140−81

@@ -1,103 +1,162 @@

1# This Travis job script has been generated by a script via

3−# make_travis_yml_2.hs '--branch' 'master' 'swagger2.cabal'

3+# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal'

5−# For more information, see https://github.com/hvr/multi-ghc-travis

5+# For more information, see https://github.com/haskell-CI/haskell-ci

6+#

7+# version: 0.5.20191020

7language: c

9language: c

8−sudo: false

10+dist: xenial

9−

10git:

11git:

11− submodules: false # whether to recursively clone submodules

12+ # whether to recursively clone submodules

12−

13+ submodules: false

13branches:

14branches:

14 only:

15 only:

15 - master

16 - master

16−

17cache:

18 directories:

19 - $HOME/.cabal/packages

20 - $HOME/.cabal/store

21−

22before_cache:

21before_cache:

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

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

24 # remove files that are regenerated by 'cabal update'

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

25− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

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

26− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

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

27− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

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

28− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

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

29− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

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

30−

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

31matrix:

30matrix:

32 include:

31 include:

33− - compiler: "ghc-7.8.4"

32+ - compiler: ghc-8.8.1

34− # env: TEST=--disable-tests BENCH=--disable-benchmarks

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

35− env: HADDOCK=false

36− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}}

37− - compiler: "ghc-7.10.3"

34+ - compiler: ghc-8.6.5

38− # env: TEST=--disable-tests BENCH=--disable-benchmarks

39− env: HADDOCK=false

40− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}

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

41− - compiler: "ghc-8.0.2"

36+ - compiler: ghc-8.4.4

42− # env: TEST=--disable-tests BENCH=--disable-benchmarks

43− env: HADDOCK=false

44− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}

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

45− - compiler: "ghc-8.2.1"

38+ - compiler: ghc-8.2.2

46− # env: TEST=--disable-tests BENCH=--disable-benchmarks

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

47− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}

40+ - compiler: ghc-8.0.2

48−

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

49before_install:

42before_install:

50− - HC=${CC}

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"

51− - unset CC

47+ - unset CC

52− - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH

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

53− - PKGNAME='swagger2'

49+ - CABALHOME=$HOME/.cabal

54−

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

55install:

74install:

56− - cabal --version

75+ - ${CABAL} --version

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

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

77+ - TEST=--enable-tests

58− - BENCH=${BENCH---enable-benchmarks}

78+ - BENCH=--enable-benchmarks

59− - TEST=${TEST---enable-tests}

79+ - HEADHACKAGE=false

60− - HADDOCK=${HADDOCK-true}

80+ - rm -f $CABALHOME/config

61− - INSTALLED=${INSTALLED-true}

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

62− - travis_retry cabal update -v

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

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

111+ # Generate cabal.project

64− - rm -fv cabal.project.local

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

65− - "echo 'packages: .' > cabal.project"

113+ - touch cabal.project

66− - rm -f cabal.project.freeze

114+ - |

67− - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all

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

68− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all

116+ - |

69−

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"

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

118+ - cat cabal.project || true

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

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

72script:

126script:

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

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

74− - rm -rf .ghc.environment.* dist/

128+ # Packaging...

75− - cabal sdist # test that a source-distribution can be generated

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

76− - cd dist/

130+ # Unpacking...

77− - SRCTAR=(${PKGNAME}-*.tar.gz)

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

78− - SRC_BASENAME="${SRCTAR/%.tar.gz}"

132+ - cd ${DISTDIR} || false

79− - tar -xvf "./$SRC_BASENAME.tar.gz"

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

80− - cd "$SRC_BASENAME/"

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

81−## from here on, CWD is inside the extracted source-tarball

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

82− - rm -fv cabal.project.local

83− - "echo 'packages: .' > cabal.project"

136+ # Generate cabal.project

84− # this builds all libraries and executables (without tests/benchmarks)

85− - rm -f cabal.project.freeze

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

86− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all

138+ - touch cabal.project

87− # this builds all libraries and executables (including tests/benchmarks)

139+ - |

88− # - rm -rf ./dist-newstyle

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

89−

141+ - |

90− # Build with installed constraints for packages in global-db

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"

91− - if $INSTALLED; then

143+ - cat cabal.project || true

92− ghc-pkg list --simple-output --names-only | sed -r 's/([a-zA-Z0-9-]+*) */--constraint=\1 installed;/g' | sed 's/;$/;all/' | xargs -d ';' cabal new-build -w ${HC} --disable-tests --disable-benchmarks;

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

93− else echo "Not building with installed constraints"; fi

145+ # Building...

94−

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

95− # build & run tests, build benchmarks

149+ # build & run tests, build benchmarks

96− - cabal new-build -w ${HC} ${TEST} ${BENCH} all

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

97− - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} all; fi

151+ # Testing...

98−

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

153+ # cabal check...

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

99− # haddock

155+ # haddock...

100− - rm -rf ./dist-newstyle

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

101− - if $HADDOCK; then cabal new-haddock -w ${HC} --disable-tests --disable-benchmarks all; else echo "Skipping haddock generation";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

102

160

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

103# EOF

162# EOF

CHANGELOG.md+107−2

@@ -1,8 +1,113 @@

1+2.5

2+---

4+Highlights:

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

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

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

9+Fixes and minor changes:

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

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

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

13+

14+2.4

15+---

16+

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

18+- Tags aren't sorted

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

20+- Schema type is optional

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

22+- Take concrete 'Proxy' as argument

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

24+- GHC-8.8 preparations

25+

26+2.3.1.1

27+-------

28+

29+- Allow `network-3.0`

30+

31+2.3.1

32+-----

33+

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

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

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

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

38+- Make nullary schemas valid

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

40+

41+2.3.0.1

42+-------

43+

44+- Support GHC-8.6

45+

46+2.3

47+---

48+

49+Major changes:

50+

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

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

53+

54+Dependencies and CI:

55+

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

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

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

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

60+

61+2.2.2

62+-----

63+

64+* Add `ToSchema Version` instance

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

66+* PVP bounds

67+

68+2.2.1

69+-----

70+

71+* Add `Semigroup` instances

72+* GHC-8.4 compatibility

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

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

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

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

77+

78+2.2

79+---

80+

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

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

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

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

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

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

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

88+

89+2.1.6

90+-----

91+

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

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

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

95+

96+2.1.5

97+-----

98+

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

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

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

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

103+

12.1.4.1

1042.1.4.1

2-------

105-------

106

4−* GHC-8.2 support (see [#95](https://github.com/GetShopTV/swagger2/issues/95))

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

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

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

72.1.4

1122.1.4

8-----

113-----

LICENSE+1−1

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

2All rights reserved.

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

README.md+2

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

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

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

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

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

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

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

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

aeson-0.11.cabal.configdeleted−1

@@ -1 +0,0 @@

1−constraints: aeson ==0.11.*

cabal.projectnew file+2

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

1+packages: .

2+tests: true

examples/hackage.hs+1−1

@@ -27,7 +27,7 @@ instance ToSchema UserSummary where

27 usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)

28 useridSchema <- declareSchemaRef (Proxy :: Proxy Int)

29 return $ NamedSchema (Just "UserSummary") $ mempty

30− & type_ .~ SwaggerObject

30+ & type_ ?~ SwaggerObject

31 & properties .~

32 [ ("summaryUsername", usernameSchema )

33 , ("summaryUserid" , useridSchema )

hackage-docs.shnew file+78

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

1+#!/bin/bash

2+set -e

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

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

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

8+ exit 1

9+fi

10+

11+user=$1

12+

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

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

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

16+ exit 1

17+fi

18+

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

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

21+

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

23+ echo "Unable to determine package name"

24+ exit 1

25+fi

26+

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

28+ echo "Unable to determine package version"

29+ exit 1

30+fi

31+

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

33+

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

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

36+

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

38+

39+ghc --version

40+cabal --version

41+stack --version

42+

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

44+then

45+ echo "Using fancy hyperlinked source"

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

47+else

48+ echo "Using boring hyperlinked source"

49+ HYPERLINK_FLAG="--hyperlink-source"

50+fi

51+

52+# Cabal dist in temporary location

53+builddir=$dir/dist

54+

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

56+stack haddock --only-dependencies

57+

58+# Configure using stack databases

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

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

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

62+

63+# Build Hadckage compatible docs

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

65+

66+# Copy into right directory

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

68+

69+# Tar and gzip

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

71+

72+# Upload

73+curl -X PUT \

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

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

76+ -u "$user" \

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

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

src/Data/Swagger.hs+10−4

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

32 -- * Re-exports

33 module Data.Swagger.Lens,

34+ module Data.Swagger.Optics,

34 module Data.Swagger.Operation,

35 module Data.Swagger.Operation,

35 module Data.Swagger.ParamSchema,

36 module Data.Swagger.ParamSchema,

36 module Data.Swagger.Schema,

37 module Data.Swagger.Schema,

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

77 SwaggerItems(..),

78 SwaggerItems(..),

78 Xml(..),

79 Xml(..),

79 Pattern,

80 Pattern,

81+ AdditionalProperties(..),

81 -- ** Responses

83 -- ** Responses

82 Responses(..),

84 Responses(..),

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

87 SecurityScheme(..),

89 SecurityScheme(..),

88 SecuritySchemeType(..),

90 SecuritySchemeType(..),

89 SecurityRequirement(..),

91 SecurityRequirement(..),

92+ SecurityDefinitions(..),

91 -- *** API key

94 -- *** API key

92 ApiKeyParams(..),

95 ApiKeyParams(..),

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

111) where

114) where

112

115

113import Data.Swagger.Lens

116import Data.Swagger.Lens

117+import Data.Swagger.Optics ()

114import Data.Swagger.Operation

118import Data.Swagger.Operation

115import Data.Swagger.ParamSchema

119import Data.Swagger.ParamSchema

116import Data.Swagger.Schema

120import Data.Swagger.Schema

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

174

178

175-- $lens

179-- $lens

176--

180--

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

182+--

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

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

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

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

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

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

180--

186--

181-- >>> :{

187-- >>> :{

182-- encode $ (mempty :: Swagger)

188-- encode $ (mempty :: Swagger)

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

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

184-- & paths .~

190-- & paths .~

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

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

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

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

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

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

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

204-- >>> :{

210-- >>> :{

205-- encode $ (mempty :: Schema)

211-- encode $ (mempty :: Schema)

206−-- & type_ .~ SwaggerBoolean

212+-- & type_ ?~ SwaggerBoolean

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

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

208-- :}

214-- :}

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

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

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

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

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

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

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

214--

220--

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

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

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

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

217--

223--

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

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

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

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

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

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

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

276--

282--

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

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

278-- schema for basic enums like

284-- schema for basic enums like

279--

285--

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

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

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

@@ -29,7 +29,6 @@ import Control.Monad.Trans.RWS.Strict as Strict

29import Control.Monad.Trans.Writer.Lazy as Lazy

30import Control.Monad.Trans.Writer.Strict as Strict

31import Data.Functor.Identity

32−import Data.Monoid

34-- | A declare monad transformer parametrized by:

33-- | A declare monad transformer parametrized by:

35--

34--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

src/Data/Swagger/Internal.hs+147−30

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

29import Data.Aeson

30import qualified Data.Aeson.Types as JSON

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

32+import Data.Hashable (Hashable)

32import qualified Data.HashMap.Strict as HashMap

33import qualified Data.HashMap.Strict as HashMap

34+import Data.HashSet.InsOrd (InsOrdHashSet)

33import Data.Map (Map)

35import Data.Map (Map)

34import qualified Data.Map as Map

36import qualified Data.Map as Map

35−import Data.Monoid

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

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

36import Data.Scientific (Scientific)

39import Data.Scientific (Scientific)

37−import Data.Set (Set)

38import Data.String (IsString(..))

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

39import Data.Text (Text)

41import Data.Text (Text)

40import qualified Data.Text as Text

42import qualified Data.Text as Text

41import GHC.Generics (Generic)

43import GHC.Generics (Generic)

42−import Network (HostName, PortNumber)

44+import Network.Socket (HostName, PortNumber)

43import Network.HTTP.Media (MediaType)

45import Network.HTTP.Media (MediaType)

44import Text.Read (readMaybe)

46import Text.Read (readMaybe)

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

64#define DEFINE_TOENCODING

66#define DEFINE_TOENCODING

65#endif

67#endif

69+-- $setup

70+-- >>> :seti -XDataKinds

71+-- >>> import Data.Aeson

72+

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

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

68type Definitions = InsOrdHashMap Text

74type Definitions = InsOrdHashMap Text

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

111 , _swaggerResponses :: Definitions Response

117 , _swaggerResponses :: Definitions Response

112

118

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

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

114− , _swaggerSecurityDefinitions :: Definitions SecurityScheme

120+ , _swaggerSecurityDefinitions :: SecurityDefinitions

115

121

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

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

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

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

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

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

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

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

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

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

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

127− , _swaggerTags :: Set Tag

133+ , _swaggerTags :: InsOrdHashSet Tag

128

134

129 -- | Additional external documentation.

135 -- | Additional external documentation.

130 , _swaggerExternalDocs :: Maybe ExternalDocs

136 , _swaggerExternalDocs :: Maybe ExternalDocs

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

246data Operation = Operation

252data Operation = Operation

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

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

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

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

249− _operationTags :: Set TagName

255+ _operationTags :: InsOrdHashSet TagName

250

256

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

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

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

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

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

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

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

304

310

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

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

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

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

307

313

308mimeListConstr :: Constr

314mimeListConstr :: Constr

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

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

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

554 , _schemaDescription :: Maybe Text

560 , _schemaDescription :: Maybe Text

555 , _schemaRequired :: [ParamName]

561 , _schemaRequired :: [ParamName]

556

562

557− , _schemaAllOf :: Maybe [Schema]

563+ , _schemaAllOf :: Maybe [Referenced Schema]

558 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

564 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

559− , _schemaAdditionalProperties :: Maybe (Referenced Schema)

565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties

560

566

561 , _schemaDiscriminator :: Maybe Text

567 , _schemaDiscriminator :: Maybe Text

562 , _schemaReadOnly :: Maybe Bool

568 , _schemaReadOnly :: Maybe Bool

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

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

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

589 _paramSchemaDefault :: Maybe Value

595 _paramSchemaDefault :: Maybe Value

590

596

591− , _paramSchemaType :: SwaggerType t

597+ , _paramSchemaType :: Maybe (SwaggerType t)

592 , _paramSchemaFormat :: Maybe Format

598 , _paramSchemaFormat :: Maybe Format

593 , _paramSchemaItems :: Maybe (SwaggerItems t)

599 , _paramSchemaItems :: Maybe (SwaggerItems t)

594 , _paramSchemaMaximum :: Maybe Scientific

600 , _paramSchemaMaximum :: Maybe Scientific

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

605 , _paramSchemaMultipleOf :: Maybe Scientific

611 , _paramSchemaMultipleOf :: Maybe Scientific

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

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

607

613

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

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

609

615

610data Xml = Xml

616data Xml = Xml

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

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

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

749 , _securitySchemeDescription :: Maybe Text

755 , _securitySchemeDescription :: Maybe Text

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

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

751

757

758+

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

760+-- In other case returns first security scheme

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

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

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

764+ = if flow1 == flow2 then

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

766+ else

767+ s1

768+mergeSecurityScheme s1 _ = s1

769+

770+newtype SecurityDefinitions

771+ = SecurityDefinitions (Definitions SecurityScheme)

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

773+

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

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

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

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

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

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

755newtype SecurityRequirement = SecurityRequirement

777newtype SecurityRequirement = SecurityRequirement

756 { getSecurityRequirement :: InsOrdHashMap Text [Text]

778 { getSecurityRequirement :: InsOrdHashMap Text [Text]

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

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

758

780

759-- | Tag name.

781-- | Tag name.

760type TagName = Text

782type TagName = Text

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

773 , _tagExternalDocs :: Maybe ExternalDocs

795 , _tagExternalDocs :: Maybe ExternalDocs

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

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

775

797

798+instance Hashable Tag

799+

776instance IsString Tag where

800instance IsString Tag where

777 fromString s = Tag (fromString s) Nothing Nothing

801 fromString s = Tag (fromString s) Nothing Nothing

778

802

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

786 , _externalDocsUrl :: URL

810 , _externalDocsUrl :: URL

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

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

788

812

813+instance Hashable ExternalDocs

814+

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

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

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

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

791newtype Reference = Reference { getReference :: Text }

817newtype Reference = Reference { getReference :: Text }

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

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

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

800 fromString = Inline . fromString

826 fromString = Inline . fromString

801

827

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

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

829+

830+data AdditionalProperties

831+ = AdditionalPropertiesAllowed Bool

832+ | AdditionalPropertiesSchema (Referenced Schema)

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

803

834

804-- =======================================================================

835-- =======================================================================

805-- Monoid instances

836-- Monoid instances

806-- =======================================================================

837-- =======================================================================

807

838

839+instance Semigroup Swagger where

840+ (<>) = genericMappend

808instance Monoid Swagger where

841instance Monoid Swagger where

809 mempty = genericMempty

842 mempty = genericMempty

810− mappend = genericMappend

843+ mappend = (<>)

811

844

845+instance Semigroup Info where

846+ (<>) = genericMappend

812instance Monoid Info where

847instance Monoid Info where

813 mempty = genericMempty

848 mempty = genericMempty

814− mappend = genericMappend

849+ mappend = (<>)

815

850

851+instance Semigroup Contact where

852+ (<>) = genericMappend

816instance Monoid Contact where

853instance Monoid Contact where

817 mempty = genericMempty

854 mempty = genericMempty

818− mappend = genericMappend

855+ mappend = (<>)

819

856

857+instance Semigroup PathItem where

858+ (<>) = genericMappend

820instance Monoid PathItem where

859instance Monoid PathItem where

821 mempty = genericMempty

860 mempty = genericMempty

822− mappend = genericMappend

861+ mappend = (<>)

823

862

863+instance Semigroup Schema where

864+ (<>) = genericMappend

824instance Monoid Schema where

865instance Monoid Schema where

825 mempty = genericMempty

866 mempty = genericMempty

826− mappend = genericMappend

867+ mappend = (<>)

827

868

869+instance Semigroup (ParamSchema t) where

870+ (<>) = genericMappend

828instance Monoid (ParamSchema t) where

871instance Monoid (ParamSchema t) where

829 mempty = genericMempty

872 mempty = genericMempty

830− mappend = genericMappend

873+ mappend = (<>)

831

874

875+instance Semigroup Param where

876+ (<>) = genericMappend

832instance Monoid Param where

877instance Monoid Param where

833 mempty = genericMempty

878 mempty = genericMempty

834− mappend = genericMappend

879+ mappend = (<>)

835

880

881+instance Semigroup ParamOtherSchema where

882+ (<>) = genericMappend

836instance Monoid ParamOtherSchema where

883instance Monoid ParamOtherSchema where

837 mempty = genericMempty

884 mempty = genericMempty

838− mappend = genericMappend

885+ mappend = (<>)

839

886

887+instance Semigroup Header where

888+ (<>) = genericMappend

840instance Monoid Header where

889instance Monoid Header where

841 mempty = genericMempty

890 mempty = genericMempty

842− mappend = genericMappend

891+ mappend = (<>)

843

892

893+instance Semigroup Responses where

894+ (<>) = genericMappend

844instance Monoid Responses where

895instance Monoid Responses where

845 mempty = genericMempty

896 mempty = genericMempty

846− mappend = genericMappend

897+ mappend = (<>)

847

898

899+instance Semigroup Response where

900+ (<>) = genericMappend

848instance Monoid Response where

901instance Monoid Response where

849 mempty = genericMempty

902 mempty = genericMempty

850− mappend = genericMappend

903+ mappend = (<>)

851

904

905+instance Semigroup ExternalDocs where

906+ (<>) = genericMappend

852instance Monoid ExternalDocs where

907instance Monoid ExternalDocs where

853 mempty = genericMempty

908 mempty = genericMempty

854− mappend = genericMappend

909+ mappend = (<>)

855

910

911+instance Semigroup Operation where

912+ (<>) = genericMappend

856instance Monoid Operation where

913instance Monoid Operation where

857 mempty = genericMempty

914 mempty = genericMempty

858− mappend = genericMappend

915+ mappend = (<>)

859

916

917+instance Semigroup Example where

918+ (<>) = genericMappend

860instance Monoid Example where

919instance Monoid Example where

861 mempty = genericMempty

920 mempty = genericMempty

862− mappend = genericMappend

921+ mappend = (<>)

922+

923+instance Semigroup SecurityScheme where

924+ (<>) = mergeSecurityScheme

925+

926+instance Semigroup SecurityDefinitions where

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

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

929+

930+instance Monoid SecurityDefinitions where

931+ mempty = SecurityDefinitions $ InsOrdHashMap.empty

932+ mappend = (<>)

863

933

864-- =======================================================================

934-- =======================================================================

865-- SwaggerMonoid helper instances

935-- SwaggerMonoid helper instances

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

875instance SwaggerMonoid Response

945instance SwaggerMonoid Response

876instance SwaggerMonoid ExternalDocs

946instance SwaggerMonoid ExternalDocs

877instance SwaggerMonoid Operation

947instance SwaggerMonoid Operation

948+instance SwaggerMonoid SecurityDefinitions

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

878

950

879instance SwaggerMonoid MimeList

951instance SwaggerMonoid MimeList

880deriving instance SwaggerMonoid URL

952deriving instance SwaggerMonoid URL

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

893

965

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

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

895 swaggerMempty = Inline mempty

967 swaggerMempty = Inline mempty

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

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

897 swaggerMappend _ y = y

969 swaggerMappend _ y = y

898

970

899instance SwaggerMonoid ParamAnySchema where

971instance SwaggerMonoid ParamAnySchema where

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

1016 toJSON = sopSwaggerGenericToJSON

1088 toJSON = sopSwaggerGenericToJSON

1017 DEFINE_TOENCODING

1089 DEFINE_TOENCODING

1018

1090

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

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

1093+--

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

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

1096+--

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

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

1020 toJSON (SwaggerItemsPrimitive fmt schema) = object

1098 toJSON (SwaggerItemsPrimitive fmt schema) = object

1021 [ "collectionFormat" .= fmt

1099 [ "collectionFormat" .= fmt

1022 , "items" .= schema ]

1100 , "items" .= schema ]

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

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

1102+ toJSON (SwaggerItemsArray []) = object

1103+ [ "items" .= object []

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

1105+ , "example" .= Array mempty

1106+ ]

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

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

1025

1108

1026instance ToJSON Host where

1109instance ToJSON Host where

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

1063instance ToJSON Example where

1146instance ToJSON Example where

1064 toJSON = toJSON . Map.mapKeys show . getExample

1147 toJSON = toJSON . Map.mapKeys show . getExample

1065

1148

1149+instance ToJSON SecurityDefinitions where

1150+ toJSON (SecurityDefinitions sd) = toJSON sd

1151+

1066instance ToJSON Reference where

1152instance ToJSON Reference where

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

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

1068

1154

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

1096 toJSON = sopSwaggerGenericToJSONWithOpts $

1182 toJSON = sopSwaggerGenericToJSONWithOpts $

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

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

1098

1184

1185+instance ToJSON AdditionalProperties where

1186+ toJSON (AdditionalPropertiesAllowed b) = toJSON b

1187+ toJSON (AdditionalPropertiesSchema s) = toJSON s

1188+

1099-- =======================================================================

1189-- =======================================================================

1100-- Manual FromJSON instances

1190-- Manual FromJSON instances

1101-- =======================================================================

1191-- =======================================================================

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

1133 parseJSON = sopSwaggerGenericParseJSON

1223 parseJSON = sopSwaggerGenericParseJSON

1134

1224

1135instance FromJSON Schema where

1225instance FromJSON Schema where

1136− parseJSON = sopSwaggerGenericParseJSON

1226+ parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON

1227+ where nullaryCleanup :: Schema -> Schema

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

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

1230+ then s { _schemaExample = Nothing

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

1232+ else s

1137

1233

1138instance FromJSON Header where

1234instance FromJSON Header where

1139 parseJSON = sopSwaggerGenericParseJSON

1235 parseJSON = sopSwaggerGenericParseJSON

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

1148 <$> o .:? "collectionFormat"

1244 <$> o .:? "collectionFormat"

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

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

1150

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

1151instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1258instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1259+ parseJSON js@(Object obj)

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

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

1261+ | otherwise = SwaggerItemsObject <$> parseJSON js

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

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

1154 parseJSON _ = empty

1263 parseJSON _ = empty

1155

1264

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

1201instance FromJSON PathItem where

1310instance FromJSON PathItem where

1202 parseJSON = sopSwaggerGenericParseJSON

1311 parseJSON = sopSwaggerGenericParseJSON

1203

1312

1313+instance FromJSON SecurityDefinitions where

1314+ parseJSON js = SecurityDefinitions <$> parseJSON js

1315+

1204instance FromJSON Reference where

1316instance FromJSON Reference where

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

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

1206 parseJSON _ = empty

1318 parseJSON _ = empty

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

1251instance FromJSON (ParamSchema 'SwaggerKindSchema) where

1363instance FromJSON (ParamSchema 'SwaggerKindSchema) where

1252 parseJSON = sopSwaggerGenericParseJSON

1364 parseJSON = sopSwaggerGenericParseJSON

1253

1365

1366+instance FromJSON AdditionalProperties where

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

1368+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js

1369+

1254-------------------------------------------------------------------------------

1370-------------------------------------------------------------------------------

1255-- TH splices

1371-- TH splices

1256-------------------------------------------------------------------------------

1372-------------------------------------------------------------------------------

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

1308instance AesonDefaultValue MimeList where defaultValue = Just mempty

1424instance AesonDefaultValue MimeList where defaultValue = Just mempty

1309instance AesonDefaultValue Info

1425instance AesonDefaultValue Info

1310instance AesonDefaultValue ParamLocation

1426instance AesonDefaultValue ParamLocation

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

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

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

44import qualified Data.HashMap.Strict as HM

45import qualified Data.Set as Set

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

47+import qualified Data.HashSet.InsOrd as InsOrdHS

48#if MIN_VERSION_aeson(0,10,0)

49#if MIN_VERSION_aeson(0,10,0)

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

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

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

51#endif

53-------------------------------------------------------------------------------

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

68makeLenses ''SwaggerAesonOptions

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

71− swaggerAesonOptions :: proxy a -> SwaggerAesonOptions

71+ swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

73 -- So far we use only default definitions

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

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

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

77-------------------------------------------------------------------------------

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

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

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

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

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

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

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

91-------------------------------------------------------------------------------

92-------------------------------------------------------------------------------

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

145 -> DatatypeInfo '[xs]

146 -> DatatypeInfo '[xs]

146 -> POP Maybe '[xs]

147 -> POP Maybe '[xs]

147 -> [Pair]

148 -> [Pair]

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

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

151+#else

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

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

153+#endif

149 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

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

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

151

156

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

221 -> DatatypeInfo '[xs]

226 -> DatatypeInfo '[xs]

222 -> POP Maybe '[xs]

227 -> POP Maybe '[xs]

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

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

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

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

231+#else

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

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

233+#endif

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

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

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

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

227

236

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

293 -> DatatypeInfo '[xs]

302 -> DatatypeInfo '[xs]

294 -> POP Maybe '[xs]

303 -> POP Maybe '[xs]

295 -> Series

304 -> Series

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

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

307+#else

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

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

309+#endif

297 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

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

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

299

312

src/Data/Swagger/Internal/ParamSchema.hs+60−25

@@ -22,7 +22,7 @@

22module Data.Swagger.Internal.ParamSchema where

24import Control.Lens

25−import Data.Aeson

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

26import Data.Proxy

27import GHC.Generics

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

31import Data.Monoid

32import Data.Set (Set)

33import Data.Scientific

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

34import qualified Data.Text as T

35import qualified Data.Text as T

35import qualified Data.Text.Lazy as TL

36import qualified Data.Text.Lazy as TL

36import Data.Time

37import Data.Time

@@ -38,8 +39,11 @@ import qualified Data.Vector as V

38import qualified Data.Vector.Primitive as VP

39import qualified Data.Vector.Primitive as VP

39import qualified Data.Vector.Storable as VS

40import qualified Data.Vector.Storable as VS

40import qualified Data.Vector.Unboxed as VU

41import qualified Data.Vector.Unboxed as VU

42+import Data.Version (Version)

43+import Numeric.Natural.Compat (Natural)

41import Data.Word

44import Data.Word

42import Data.UUID.Types (UUID)

45import Data.UUID.Types (UUID)

46+import Web.Cookie (SetCookie)

44import Data.Swagger.Internal

48import Data.Swagger.Internal

45import Data.Swagger.Lens

49import Data.Swagger.Lens

@@ -55,20 +59,20 @@ import GHC.TypeLits (TypeError, ErrorMessage(..))

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

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

56binaryParamSchema :: ParamSchema t

60binaryParamSchema :: ParamSchema t

57binaryParamSchema = mempty

61binaryParamSchema = mempty

58− & type_ .~ SwaggerString

62+ & type_ ?~ SwaggerString

59 & format ?~ "binary"

63 & format ?~ "binary"

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

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

62byteParamSchema :: ParamSchema t

66byteParamSchema :: ParamSchema t

63byteParamSchema = mempty

67byteParamSchema = mempty

64− & type_ .~ SwaggerString

68+ & type_ ?~ SwaggerString

65 & format ?~ "byte"

69 & format ?~ "byte"

67-- | Default schema for password string.

71-- | Default schema for password string.

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

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

69passwordParamSchema :: ParamSchema t

73passwordParamSchema :: ParamSchema t

70passwordParamSchema = mempty

74passwordParamSchema = mempty

71− & type_ .~ SwaggerString

75+ & type_ ?~ SwaggerString

72 & format ?~ "password"

76 & format ?~ "password"

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

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

@@ -84,7 +88,7 @@ passwordParamSchema = mempty

84--

88--

85-- instance ToParamSchema Direction where

89-- instance ToParamSchema Direction where

86-- toParamSchema _ = mempty

90-- toParamSchema _ = mempty

87−-- & type_ .~ SwaggerString

91+-- & type_ ?~ SwaggerString

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

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

89-- @

93-- @

90--

94--

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

111 --

115 --

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

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

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

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

114− toParamSchema :: proxy a -> ParamSchema t

118+ toParamSchema :: Proxy a -> ParamSchema t

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

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

116 toParamSchema = genericToParamSchema defaultSchemaOptions

120 toParamSchema = genericToParamSchema defaultSchemaOptions

117

121

118instance OVERLAPPING_ ToParamSchema String where

122instance OVERLAPPING_ ToParamSchema String where

119− toParamSchema _ = mempty & type_ .~ SwaggerString

123+ toParamSchema _ = mempty & type_ ?~ SwaggerString

120

124

121instance ToParamSchema Bool where

125instance ToParamSchema Bool where

122− toParamSchema _ = mempty & type_ .~ SwaggerBoolean

126+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

123

127

124instance ToParamSchema Integer where

128instance ToParamSchema Integer where

125− toParamSchema _ = mempty & type_ .~ SwaggerInteger

129+ toParamSchema _ = mempty & type_ ?~ SwaggerInteger

130+

131+instance ToParamSchema Natural where

132+ toParamSchema _ = mempty

133+ & type_ ?~ SwaggerInteger

134+ & minimum_ ?~ 0

135+ & exclusiveMinimum ?~ False

126

136

127instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral

137instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral

128instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral

138instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral

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

144--

154--

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

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

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

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

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

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

148toParamSchemaBoundedIntegral _ = mempty

158toParamSchemaBoundedIntegral _ = mempty

149− & type_ .~ SwaggerInteger

159+ & type_ ?~ SwaggerInteger

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

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

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

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

152

162

153instance ToParamSchema Char where

163instance ToParamSchema Char where

154 toParamSchema _ = mempty

164 toParamSchema _ = mempty

155− & type_ .~ SwaggerString

165+ & type_ ?~ SwaggerString

156 & maxLength ?~ 1

166 & maxLength ?~ 1

157 & minLength ?~ 1

167 & minLength ?~ 1

158

168

159instance ToParamSchema Scientific where

169instance ToParamSchema Scientific where

160− toParamSchema _ = mempty & type_ .~ SwaggerNumber

170+ toParamSchema _ = mempty & type_ ?~ SwaggerNumber

171+

172+instance HasResolution a => ToParamSchema (Fixed a) where

173+ toParamSchema _ = mempty

174+ & type_ ?~ SwaggerNumber

175+ & multipleOf ?~ (recip . fromInteger $ resolution (Proxy :: Proxy a))

161

176

162instance ToParamSchema Double where

177instance ToParamSchema Double where

163 toParamSchema _ = mempty

178 toParamSchema _ = mempty

164− & type_ .~ SwaggerNumber

179+ & type_ ?~ SwaggerNumber

165 & format ?~ "double"

180 & format ?~ "double"

166

181

167instance ToParamSchema Float where

182instance ToParamSchema Float where

168 toParamSchema _ = mempty

183 toParamSchema _ = mempty

169− & type_ .~ SwaggerNumber

184+ & type_ ?~ SwaggerNumber

170 & format ?~ "float"

185 & format ?~ "float"

171

186

172timeParamSchema :: String -> ParamSchema t

187timeParamSchema :: String -> ParamSchema t

173timeParamSchema fmt = mempty

188timeParamSchema fmt = mempty

174− & type_ .~ SwaggerString

189+ & type_ ?~ SwaggerString

175 & format ?~ T.pack fmt

190 & format ?~ T.pack fmt

176

191

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

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

178instance ToParamSchema Day where

193instance ToParamSchema Day where

179 toParamSchema _ = timeParamSchema "date"

194 toParamSchema _ = timeParamSchema "date"

180

195

196+-- |

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

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

199+instance ToParamSchema TimeOfDay where

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

201+

181-- |

202-- |

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

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

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

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

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

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

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

198

219

199instance ToParamSchema NominalDiffTime where

220instance ToParamSchema NominalDiffTime where

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

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

201

222

202instance ToParamSchema T.Text where

223instance ToParamSchema T.Text where

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

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

@@ -205,6 +226,16 @@ instance ToParamSchema T.Text where

205instance ToParamSchema TL.Text where

226instance ToParamSchema TL.Text where

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

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

207

228

229+instance ToParamSchema Version where

230+ toParamSchema _ = mempty

231+ & type_ ?~ SwaggerString

232+ & pattern ?~ "^\\d+(\\.\\d+)*$"

233+

234+instance ToParamSchema SetCookie where

235+ toParamSchema _ = mempty

236+ & type_ ?~ SwaggerString

237+

238+

208#if __GLASGOW_HASKELL__ < 800

239#if __GLASGOW_HASKELL__ < 800

209#else

240#else

210type family ToParamSchemaByteStringError bs where

241type family ToParamSchemaByteStringError bs where

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

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

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

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

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

227

258

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

260+

228instance ToParamSchema a => ToParamSchema [a] where

261instance ToParamSchema a => ToParamSchema [a] where

229 toParamSchema _ = mempty

262 toParamSchema _ = mempty

230− & type_ .~ SwaggerArray

263+ & type_ ?~ SwaggerArray

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

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

232

265

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

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

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

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

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

248instance ToParamSchema () where

281instance ToParamSchema () where

249 toParamSchema _ = mempty

282 toParamSchema _ = mempty

250− & type_ .~ SwaggerString

283+ & type_ ?~ SwaggerString

251 & enum_ ?~ ["_"]

284 & enum_ ?~ ["_"]

252

285

253instance ToParamSchema UUID where

286instance ToParamSchema UUID where

254 toParamSchema _ = mempty

287 toParamSchema _ = mempty

255− & type_ .~ SwaggerString

288+ & type_ ?~ SwaggerString

256 & format ?~ "uuid"

289 & format ?~ "uuid"

257

290

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

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

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

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

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

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

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

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

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

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

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

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

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

266

299

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

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

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

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

269

302

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

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

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

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

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

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

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

284

317

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

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

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

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

287

320

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

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

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

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

290

323

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

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

292 genumParamSchema opts _ s = s

325 genumParamSchema opts _ s = s

293− & type_ .~ SwaggerString

326+ & type_ ?~ SwaggerString

294 & enum_ %~ addEnumValue tag

327 & enum_ %~ addEnumValue tag

295 where

328 where

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

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

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

300

333

301data Proxy3 a b c = Proxy3

334data Proxy3 a b c = Proxy3

302

335

336+-- $setup

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

src/Data/Swagger/Internal/Schema.hs+159−68

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

33import Control.Monad

34import Control.Monad.Writer

35−import Data.Aeson

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

36import Data.Char

37import Data.Data (Data)

38import Data.Foldable (traverse_)

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

44import Data.Int

45import Data.IntSet (IntSet)

46import Data.IntMap (IntMap)

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

47import Data.Map (Map)

48import Data.Map (Map)

48import Data.Proxy

49import Data.Proxy

49import Data.Scientific (Scientific)

50import Data.Scientific (Scientific)

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

50import Data.Set (Set)

52import Data.Set (Set)

51import qualified Data.Text as T

53import qualified Data.Text as T

52import qualified Data.Text.Lazy as TL

54import qualified Data.Text.Lazy as TL

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

55import qualified Data.Vector.Primitive as VP

57import qualified Data.Vector.Primitive as VP

56import qualified Data.Vector.Storable as VS

58import qualified Data.Vector.Storable as VS

57import qualified Data.Vector.Unboxed as VU

59import qualified Data.Vector.Unboxed as VU

60+import Data.Version (Version)

61+import Numeric.Natural.Compat (Natural)

58import Data.Word

62import Data.Word

59import GHC.Generics

63import GHC.Generics

60import qualified Data.UUID.Types as UUID

64import qualified Data.UUID.Types as UUID

@@ -107,7 +111,7 @@ rename name (NamedSchema _ schema) = NamedSchema name schema

107-- declareNamedSchema _ = do

111-- declareNamedSchema _ = do

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

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

109-- return $ NamedSchema (Just \"Coord\") $ mempty

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

110−-- & type_ .~ SwaggerObject

114+-- & type_ ?~ SwaggerObject

111-- & properties .~

115-- & properties .~

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

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

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

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

@@ -138,13 +142,17 @@ class ToSchema a where

138 -- together with all used definitions.

142 -- together with all used definitions.

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

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

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

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

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

145+ declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema

142 default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

146 default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

143− proxy a -> Declare (Definitions Schema) NamedSchema

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

144 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

145

149

150+instance ToSchema TimeOfDay where

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

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

153+

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

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

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

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

148declareSchema = fmap _namedSchemaSchema . declareNamedSchema

156declareSchema = fmap _namedSchemaSchema . declareNamedSchema

149

157

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

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

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

158-- Just "Day"

166-- Just "Day"

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

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

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

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

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

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

162toNamedSchema = undeclare . declareNamedSchema

170toNamedSchema = undeclare . declareNamedSchema

163

171

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

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

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

168--

176--

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

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

170-- Just "UTCTime"

178-- Just "UTCTime"

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

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

172schemaName = _namedSchemaName . toNamedSchema

180schemaName = _namedSchemaName . toNamedSchema

173

181

174-- | Convert a type into a schema.

182-- | Convert a type into a schema.

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

178--

186--

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

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

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

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

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

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

182toSchema = _namedSchemaSchema . toNamedSchema

190toSchema = _namedSchemaSchema . toNamedSchema

183

191

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

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

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

189--

197--

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

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

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

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

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

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

193toSchemaRef = undeclare . declareSchemaRef

201toSchemaRef = undeclare . declareSchemaRef

194

202

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

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

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

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

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

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

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

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

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

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

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

203declareSchemaRef proxy = do

211declareSchemaRef proxy = do

204 case toNamedSchema proxy of

212 case toNamedSchema proxy of

205 NamedSchema (Just name) schema -> do

213 NamedSchema (Just name) schema -> do

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

261--

269--

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

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

263-- when inlining recursive schemas.

271-- when inlining recursive schemas.

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

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

265toInlinedSchema proxy = inlineAllSchemas defs schema

273toInlinedSchema proxy = inlineAllSchemas defs schema

266 where

274 where

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

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

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

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

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

291binarySchema :: Schema

299binarySchema :: Schema

292binarySchema = mempty

300binarySchema = mempty

293− & type_ .~ SwaggerString

301+ & type_ ?~ SwaggerString

294 & format ?~ "binary"

302 & format ?~ "binary"

295

303

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

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

297byteSchema :: Schema

305byteSchema :: Schema

298byteSchema = mempty

306byteSchema = mempty

299− & type_ .~ SwaggerString

307+ & type_ ?~ SwaggerString

300 & format ?~ "byte"

308 & format ?~ "byte"

301

309

302-- | Default schema for password string.

310-- | Default schema for password string.

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

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

304passwordSchema :: Schema

312passwordSchema :: Schema

305passwordSchema = mempty

313passwordSchema = mempty

306− & type_ .~ SwaggerString

314+ & type_ ?~ SwaggerString

307 & format ?~ "password"

315 & format ?~ "password"

308

316

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

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

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

329 sketch js@(Bool _) = go js

337 sketch js@(Bool _) = go js

330 sketch js = go js & example ?~ js

338 sketch js = go js & example ?~ js

331

339

332− go Null = mempty & type_ .~ SwaggerNull

340+ go Null = mempty & type_ ?~ SwaggerNull

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

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

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

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

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

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

336 go (Array xs) = mempty

344 go (Array xs) = mempty

337− & type_ .~ SwaggerArray

345+ & type_ ?~ SwaggerArray

338 & items ?~ case ischema of

346 & items ?~ case ischema of

339 Just s -> SwaggerItemsObject (Inline s)

347 Just s -> SwaggerItemsObject (Inline s)

340 _ -> SwaggerItemsArray (map Inline ys)

348 _ -> SwaggerItemsArray (map Inline ys)

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

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

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

347 _ -> Nothing

355 _ -> Nothing

348 go (Object o) = mempty

356 go (Object o) = mempty

349− & type_ .~ SwaggerObject

357+ & type_ ?~ SwaggerObject

350 & required .~ HashMap.keys o

358 & required .~ HashMap.keys o

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

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

352

360

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

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

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

370sketchStrictSchema = go . toJSON

378sketchStrictSchema = go . toJSON

371 where

379 where

372− go Null = mempty & type_ .~ SwaggerNull

380+ go Null = mempty & type_ ?~ SwaggerNull

373 go js@(Bool _) = mempty

381 go js@(Bool _) = mempty

374− & type_ .~ SwaggerBoolean

382+ & type_ ?~ SwaggerBoolean

375 & enum_ ?~ [js]

383 & enum_ ?~ [js]

376 go js@(String s) = mempty

384 go js@(String s) = mempty

377− & type_ .~ SwaggerString

385+ & type_ ?~ SwaggerString

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

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

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

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

380 & pattern ?~ s

388 & pattern ?~ s

381 & enum_ ?~ [js]

389 & enum_ ?~ [js]

382 go js@(Number n) = mempty

390 go js@(Number n) = mempty

383− & type_ .~ SwaggerNumber

391+ & type_ ?~ SwaggerNumber

384 & maximum_ ?~ n

392 & maximum_ ?~ n

385 & minimum_ ?~ n

393 & minimum_ ?~ n

386 & multipleOf ?~ n

394 & multipleOf ?~ n

387 & enum_ ?~ [js]

395 & enum_ ?~ [js]

388 go js@(Array xs) = mempty

396 go js@(Array xs) = mempty

389− & type_ .~ SwaggerArray

397+ & type_ ?~ SwaggerArray

390 & maxItems ?~ fromIntegral sz

398 & maxItems ?~ fromIntegral sz

391 & minItems ?~ fromIntegral sz

399 & minItems ?~ fromIntegral sz

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

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

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

396 sz = length xs

404 sz = length xs

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

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

398 go js@(Object o) = mempty

406 go js@(Object o) = mempty

399− & type_ .~ SwaggerObject

407+ & type_ ?~ SwaggerObject

400 & required .~ names

408 & required .~ names

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

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

402 & maxProperties ?~ fromIntegral (length names)

410 & maxProperties ?~ fromIntegral (length names)

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

406 names = HashMap.keys o

414 names = HashMap.keys o

407

415

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

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

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

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

410

418

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

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

412 declareNamedSchema _ = do

420 declareNamedSchema _ = do

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

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

414 return $ unnamed $ mempty

422 return $ unnamed $ mempty

415− & type_ .~ SwaggerArray

423+ & type_ ?~ SwaggerArray

416 & items ?~ SwaggerItemsObject ref

424 & items ?~ SwaggerItemsObject ref

417

425

418instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

419instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema

427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema

420instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema

428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema

429+instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema

421instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema

430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema

422instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema

431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema

423instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema

432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema

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

437instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema

446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema

438instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema

447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema

439

448

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

450+

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

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

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

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

442

453

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

459

470

460timeSchema :: T.Text -> Schema

471timeSchema :: T.Text -> Schema

461timeSchema fmt = mempty

472timeSchema fmt = mempty

462− & type_ .~ SwaggerString

473+ & type_ ?~ SwaggerString

463 & format ?~ fmt

474 & format ?~ fmt

464

475

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

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

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

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

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

481

492

482instance ToSchema NominalDiffTime where

493instance ToSchema NominalDiffTime where

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

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

484

495

485-- |

496-- |

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

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

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

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

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

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

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

494

505

506+instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema

507+

495#if __GLASGOW_HASKELL__ < 800

508#if __GLASGOW_HASKELL__ < 800

496#else

509#else

497type family ToSchemaByteStringError bs where

510type family ToSchemaByteStringError bs where

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

519 declareObjectMapSchema = do

532 declareObjectMapSchema = do

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

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

521 return $ unnamed $ mempty

534 return $ unnamed $ mempty

522− & type_ .~ SwaggerObject

535+ & type_ ?~ SwaggerObject

523− & additionalProperties ?~ schema

536+ & additionalProperties ?~ AdditionalPropertiesSchema schema

524

537

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

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

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

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

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

531 declareNamedSchema _ = do

544 declareNamedSchema _ = do

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

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

533 return $ unnamed $ mempty

546 return $ unnamed $ mempty

534− & type_ .~ SwaggerObject

547+ & type_ ?~ SwaggerObject

535 & additionalProperties ?~ schema

548 & additionalProperties ?~ schema

536

549

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

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

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

543

556

544#endif

557#endif

545

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+

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

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

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

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

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

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

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

556

575

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

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

558

577

578+-- | @since 2.2.1

579+instance ToSchema a => ToSchema (NonEmpty a) where

580+ declareNamedSchema _ = do

581+ schema <- declareSchema (Proxy :: Proxy [a])

582+ return $ unnamed $ schema

583+ & minItems .~ Just 1

584+

559instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema

585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema

560instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

561

587

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

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

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

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

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

567

593

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

595+

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

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

569--

597--

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

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

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

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

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

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

573toSchemaBoundedIntegral _ = mempty

601toSchemaBoundedIntegral _ = mempty

574− & type_ .~ SwaggerInteger

602+ & type_ ?~ SwaggerInteger

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

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

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

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

577

605

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

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

579−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

607+genericToNamedSchemaBoundedIntegral :: forall a d f.

580 ( Bounded a, Integral a

608 ( Bounded a, Integral a

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

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

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

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

583genericToNamedSchemaBoundedIntegral opts proxy

611genericToNamedSchemaBoundedIntegral opts proxy

584− = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (toSchemaBoundedIntegral proxy)

612+ = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

613+

614+-- | Declare a named schema for a @newtype@ wrapper.

615+genericDeclareNamedSchemaNewtype :: forall a d c s i inner.

616+ (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))

617+ => SchemaOptions -- ^ How to derive the name.

618+ -> (Proxy inner -> Declare (Definitions Schema) Schema) -- ^ How to create a schema for the wrapped type.

619+ -> Proxy a

620+ -> Declare (Definitions Schema) NamedSchema

621+genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)

622+

623+-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.

624+-- This makes a much more useful schema when there aren't many options for key values.

625+--

626+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)

627+-- >>> instance ToJSON ButtonState

628+-- >>> instance ToSchema ButtonState

629+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

630+-- >>> type ImageUrl = T.Text

631+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))

632+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"

633+--

634+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.

635+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.

636+declareSchemaBoundedEnumKeyMapping :: forall map key value.

637+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

638+ => Proxy (map key value) -> Declare (Definitions Schema) Schema

639+declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

640+ ToJSONKeyText keyToText _ -> objectSchema keyToText

641+ ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])

642+ where

643+ objectSchema keyToText = do

644+ valueRef <- declareSchemaRef (Proxy :: Proxy value)

645+ let allKeys = [minBound..maxBound :: key]

646+ mkPair k = (keyToText k, valueRef)

647+ return $ mempty

648+ & type_ ?~ SwaggerObject

649+ & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)

650+

651+-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.

652+-- This makes a much more useful schema when there aren't many options for key values.

653+--

654+-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)

655+-- >>> instance ToJSON ButtonState

656+-- >>> instance ToSchema ButtonState

657+-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

658+-- >>> type ImageUrl = T.Text

659+-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))

660+-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"

661+--

662+-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.

663+-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.

664+toSchemaBoundedEnumKeyMapping :: forall map key value.

665+ (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

666+ => Proxy (map key value) -> Schema

667+toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

585

668

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

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

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

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

588− SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema

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

589genericDeclareSchema = genericDeclareSchemaUnrestricted

672genericDeclareSchema = genericDeclareSchemaUnrestricted

590

673

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

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

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

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

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

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

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

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

595−genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

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

596− SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

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

597genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

680genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

598

681

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

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

600--

683--

601-- Unlike 'genericDeclareSchema' also works for mixed sum types.

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

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

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

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

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

604genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy

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

605

688

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

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

607--

690--

608-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.

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

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

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

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

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

611− SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

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

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

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

613

696

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

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

615−gdatatypeSchemaName opts _ = case name of

704+gdatatypeSchemaName opts _ = case orig of

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

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

617 _ -> Nothing

706 _ -> Nothing

618 where

707 where

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

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

709+ name = datatypeNameModifier opts orig

620

710

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

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

622−paramSchemaToNamedSchema :: forall a d f proxy.

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

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

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

713+ SchemaOptions -> Proxy a -> NamedSchema

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

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

626

715

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

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

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

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

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

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

630

719

631nullarySchema :: Schema

720nullarySchema :: Schema

632nullarySchema = mempty

721nullarySchema = mempty

633− & type_ .~ SwaggerArray

722+ & type_ ?~ SwaggerArray

634 & items ?~ SwaggerItemsArray []

723 & items ?~ SwaggerItemsArray []

635

724

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

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

637gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

638

727

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

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

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

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

641

730

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

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

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

656 gdeclareNamedSchema = gdeclareNamedSumSchema

745 gdeclareNamedSchema = gdeclareNamedSumSchema

657

746

658-- | Single field constructor.

747-- | Single field constructor.

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

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

660 gdeclareNamedSchema opts _ s

749 gdeclareNamedSchema opts _ s

661 | unwrapUnaryRecords opts = fieldSchema

750 | unwrapUnaryRecords opts = fieldSchema

662 | otherwise =

751 | otherwise =

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

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

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

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

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

672

761

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

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

674gdeclareSchemaRef opts proxy = do

763gdeclareSchemaRef opts proxy = do

675 case gtoNamedSchema opts proxy of

764 case gtoNamedSchema opts proxy of

676 NamedSchema (Just name) schema -> do

765 NamedSchema (Just name) schema -> do

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

701 return $

790 return $

702 if T.null fname

791 if T.null fname

703 then schema

792 then schema

704− & type_ .~ SwaggerArray

793+ & type_ ?~ SwaggerArray

705 & items %~ appendItem ref

794 & items %~ appendItem ref

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

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

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

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

708 else schema

797 else schema

709− & type_ .~ SwaggerObject

798+ & type_ ?~ SwaggerObject

710 & properties . at fname ?~ ref

799 & properties . at fname ?~ ref

711 & if isRequiredField

800 & if isRequiredField

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

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

@@ -734,7 +823,7 @@ instance ( GSumToSchema f

734 where

823 where

735 gdeclareNamedSchema = gdeclareNamedSumSchema

824 gdeclareNamedSchema = gdeclareNamedSumSchema

736

825

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

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

738gdeclareNamedSumSchema opts proxy s

827gdeclareNamedSumSchema opts proxy s

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

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

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

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

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

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

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

744

833

745 toStringTag schema = mempty

834 toStringTag schema = mempty

746− & type_ .~ SwaggerString

835+ & type_ ?~ SwaggerString

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

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

748

837

749type AllNullary = All

838type AllNullary = All

750

839

751class GSumToSchema (f :: * -> *) where

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

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

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

753

842

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

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

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

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

756

845

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

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

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

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

759gsumConToSchemaWith ref opts _ schema = schema

848gsumConToSchemaWith ref opts _ schema = schema

760− & type_ .~ SwaggerObject

849+ & type_ ?~ SwaggerObject

761 & properties . at tag ?~ ref

850 & properties . at tag ?~ ref

762 & maxProperties ?~ 1

851 & maxProperties ?~ 1

763 & minProperties ?~ 1

852 & minProperties ?~ 1

764 where

853 where

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

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

766

855

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

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

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

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

769gsumConToSchema opts proxy schema = do

858gsumConToSchema opts proxy schema = do

770 ref <- gdeclareSchemaRef opts proxy

859 ref <- gdeclareSchemaRef opts proxy

771 return $ gsumConToSchemaWith ref opts proxy schema

860 return $ gsumConToSchemaWith ref opts proxy schema

@@ -789,3 +878,5 @@ data Proxy3 a b c = Proxy3

789

878

790-- $setup

879-- $setup

791-- >>> import Data.Swagger

880-- >>> import Data.Swagger

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

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

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

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

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE DataKinds #-}

1−{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE PackageImports #-}

10+{-# LANGUAGE PackageImports #-}

9−{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TemplateHaskell #-}

13+{-# LANGUAGE TemplateHaskell #-}

12−{-# LANGUAGE UndecidableInstances #-}

14+{-# LANGUAGE UndecidableInstances #-}

13-- |

15-- |

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

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

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

20-- Validate JSON values with Swagger Schema.

22-- Validate JSON values with Swagger Schema.

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

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

23−import Control.Applicative

25+import Prelude ()

24−import Control.Lens

26+import Prelude.Compat

25−import Control.Monad (when)

28+import Control.Applicative

29+import Control.Lens

30+import Control.Monad (when)

31+

27−import Data.Aeson hiding (Result)

32+import Data.Aeson hiding (Result)

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

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

34+import Data.Foldable (for_, sequenceA_,

35+ traverse_)

29−import Data.HashMap.Strict (HashMap)

36+import Data.HashMap.Strict (HashMap)

30−import qualified Data.HashMap.Strict as HashMap

37+import qualified Data.HashMap.Strict as HashMap

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

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

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

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

33−import Data.Monoid

34−import Data.Proxy

40+import Data.Proxy

35−import Data.Scientific (Scientific, isInteger)

41+import Data.Scientific (Scientific, isInteger)

36−import Data.Text (Text)

42+import Data.Text (Text)

37−import qualified Data.Text as Text

43+import qualified Data.Text as Text

44+import qualified Data.Text.Lazy as TL

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

38−import Data.Vector (Vector)

46+import Data.Vector (Vector)

39−import qualified Data.Vector as Vector

47+import qualified Data.Vector as Vector

40−

48+

41−import Data.Swagger.Declare

49+import Data.Swagger.Declare

42−import Data.Swagger.Internal

50+import Data.Swagger.Internal

43−import Data.Swagger.Internal.Schema

51+import Data.Swagger.Internal.Schema

44−import Data.Swagger.Lens

52+import Data.Swagger.Lens

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

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

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

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

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

50--

58--

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

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

52-- See @'validateToJSONWithPatternChecker'@.

60-- See @'validateToJSONWithPatternChecker'@.

61+--

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

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

64+validatePrettyToJSON = renderValidationErrors validateToJSON

65+

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

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

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

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

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

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

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

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

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

58--

72--

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

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

74+-- 'renderValidationErrors'.

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

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

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

62−validateToJSONWithPatternChecker checker x =

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 =

63 case runValidation (validateWithSchema js) cfg sch of

170 case runValidation (validateWithSchema js) cfg sch of

64 Failed xs -> xs

171 Failed xs -> xs

65 Passed _ -> mempty

172 Passed _ -> mempty

66 where

173 where

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

68− js = toJSON x

69 cfg = defaultConfig

174 cfg = defaultConfig

70 { configPatternChecker = checker

175 { configPatternChecker = checker

71 , configDefinitions = defs }

176 , configDefinitions = defs }

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

158

263

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

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

160-- and property checker.

265-- and property checker.

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

266+checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

162−check l g = withSchema $ \sch ->

267+checkMissing missing l g = withSchema $ \sch ->

163 case sch ^. l of

268 case sch ^. l of

164− Nothing -> valid

269+ Nothing -> missing

165 Just x -> g x

270 Just x -> g x

166

271

272+-- | Validate schema's property given a lens into that property

273+-- and property checker.

274+-- If property is missing in schema, consider it valid.

275+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

276+check = checkMissing valid

277+

167-- | Validate same value with different schema.

278-- | Validate same value with different schema.

168sub :: t -> Validation t a -> Validation s a

279sub :: t -> Validation t a -> Validation s a

169sub = lmap . const

280sub = lmap . const

@@ -292,34 +403,109 @@ validateObject o = withSchema $ \sch ->

292 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

403 Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

293 _ ->

404 _ ->

294 case InsOrdHashMap.lookup k (sch ^. properties) of

405 case InsOrdHashMap.lookup k (sch ^. properties) of

295− Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

406+ Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v

296 Just s -> validateWithSchemaRef s v

407 Just s -> validateWithSchemaRef s v

297

408

409+ validateAdditional _ _ (AdditionalPropertiesAllowed True) = valid

410+ validateAdditional k _ (AdditionalPropertiesAllowed False) = invalid $ "additionalProperties=false but extra property " <> show k <> " found"

411+ validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v

412+

413+ unknownProperty :: Text -> Validation s a

414+ unknownProperty pname = invalid $

415+ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"

416+

298validateEnum :: Value -> Validation (ParamSchema t) ()

417validateEnum :: Value -> Validation (ParamSchema t) ()

299validateEnum value = do

418validateEnum value = do

300 check enum_ $ \xs ->

419 check enum_ $ \xs ->

301 when (value `notElem` xs) $

420 when (value `notElem` xs) $

302 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

421 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

303

422

423+-- | Infer schema type based on used properties.

424+--

425+-- This is like 'inferParamSchemaTypes', but also works for objects:

426+--

427+-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"

428+-- Just [SwaggerObject]

429+inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]

430+inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++

431+ [ SwaggerObject | any ($ sch)

432+ [ has (additionalProperties._Just)

433+ , has (maxProperties._Just)

434+ , has (minProperties._Just)

435+ , has (properties.folded)

436+ , has (required.folded) ] ]

437+

438+-- | Infer schema type based on used properties.

439+--

440+-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"

441+-- Just [SwaggerString]

442+--

443+-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"

444+-- Just [SwaggerArray]

445+--

446+-- From numeric properties 'SwaggerInteger' type is inferred.

447+-- If you want 'SwaggerNumber' instead, you must specify it explicitly.

448+--

449+-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"

450+-- Just [SwaggerInteger]

451+inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]

452+inferParamSchemaTypes sch = concat

453+ [ [ SwaggerArray | any ($ sch)

454+ [ has (items._Just)

455+ , has (maxItems._Just)

456+ , has (minItems._Just)

457+ , has (uniqueItems._Just) ] ]

458+ , [ SwaggerInteger | any ($ sch)

459+ [ has (exclusiveMaximum._Just)

460+ , has (exclusiveMinimum._Just)

461+ , has (maximum_._Just)

462+ , has (minimum_._Just)

463+ , has (multipleOf._Just) ] ]

464+ , [ SwaggerString | any ($ sch)

465+ [ has (maxLength._Just)

466+ , has (minLength._Just)

467+ , has (pattern._Just) ] ]

468+ ]

469+

304validateSchemaType :: Value -> Validation Schema ()

470validateSchemaType :: Value -> Validation Schema ()

305validateSchemaType value = withSchema $ \sch ->

471validateSchemaType value = withSchema $ \sch ->

306 case (sch ^. type_, value) of

472 case (sch ^. type_, value) of

307− (SwaggerNull, Null) -> valid

473+ (Just SwaggerNull, Null) -> valid

308− (SwaggerBoolean, Bool _) -> valid

474+ (Just SwaggerBoolean, Bool _) -> valid

309− (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

475+ (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

310− (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

476+ (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

311− (SwaggerString, String s) -> sub_ paramSchema (validateString s)

477+ (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)

312− (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

478+ (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

313− (SwaggerObject, Object o) -> validateObject o

479+ (Just SwaggerObject, Object o) -> validateObject o

480+ (Nothing, Null) -> valid

481+ (Nothing, Bool _) -> valid

482+ -- Number by default

483+ (Nothing, Number n) -> sub_ paramSchema (validateNumber n)

484+ (Nothing, String s) -> sub_ paramSchema (validateString s)

485+ (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)

486+ (Nothing, Object o) -> validateObject o

314− (t, _) -> invalid $ "expected JSON value of type " ++ show t

487+ bad -> invalid $ "expected JSON value of type " ++ showType bad

315

488

316validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

317validateParamSchemaType value = withSchema $ \sch ->

490validateParamSchemaType value = withSchema $ \sch ->

318 case (sch ^. type_, value) of

491 case (sch ^. type_, value) of

319− (SwaggerBoolean, Bool _) -> valid

492+ (Just SwaggerBoolean, Bool _) -> valid

320− (SwaggerInteger, Number n) -> validateInteger n

493+ (Just SwaggerInteger, Number n) -> validateInteger n

321− (SwaggerNumber, Number n) -> validateNumber n

494+ (Just SwaggerNumber, Number n) -> validateNumber n

322− (SwaggerString, String s) -> validateString s

495+ (Just SwaggerString, String s) -> validateString s

323− (SwaggerArray, Array xs) -> validateArray xs

496+ (Just SwaggerArray, Array xs) -> validateArray xs

497+ (Nothing, Bool _) -> valid

498+ -- Number by default

499+ (Nothing, Number n) -> validateNumber n

500+ (Nothing, String s) -> validateString s

501+ (Nothing, Array xs) -> validateArray xs

324− (t, _) -> invalid $ "expected JSON value of type " ++ show t

502+ bad -> invalid $ "expected JSON value of type " ++ showType bad

325−

503+

504+showType :: (Maybe (SwaggerType t), Value) -> String

505+showType (Just type_, _) = show type_

506+showType (Nothing, Null) = "SwaggerNull"

507+showType (Nothing, Bool _) = "SwaggerBoolean"

508+showType (Nothing, Number _) = "SwaggerNumber"

509+showType (Nothing, String _) = "SwaggerString"

510+showType (Nothing, Array _) = "SwaggerArray"

511+showType (Nothing, Object _) = "SwaggerObject"

src/Data/Swagger/Internal/Utils.hs−1

@@ -21,7 +21,6 @@ import qualified Data.HashMap.Strict as HashMap

21import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

22import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

23import Data.Map (Map)

24−import Data.Monoid

25import Data.Set (Set)

24import Data.Set (Set)

26import Data.Text (Text)

25import Data.Text (Text)

27import GHC.Generics

26import GHC.Generics

src/Data/Swagger/Lens.hs+10−4

@@ -96,13 +96,19 @@ instance At Responses where at n = responses . at n

96instance Ixed Operation where ix n = responses . ix n

97instance At Operation where at n = responses . at n

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+

99instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

105instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

100

106

101-- HasType instances

107-- HasType instances

102−instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_

108+instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_

103−instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

109+instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

104−instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

110+instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

105−instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_

111+instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_

106

112

107-- HasDefault instances

113-- HasDefault instances

108instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

114instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

src/Data/Swagger/Operation.hs+5−5

@@ -37,7 +37,7 @@ import Control.Lens

37import Data.Data.Lens

38import Data.List.Compat

39import Data.Maybe (mapMaybe)

40−import Data.Monoid

40+import Data.Proxy

41import qualified Data.Set as Set

43import Data.Swagger.Declare

@@ -46,6 +46,7 @@ import Data.Swagger.Lens

46import Data.Swagger.Schema

48import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

49+import qualified Data.HashSet.InsOrd as InsOrdHS

50-- $setup

51-- $setup

51-- >>> import Data.Aeson

52-- >>> import Data.Aeson

@@ -111,15 +112,15 @@ applyTags = applyTagsFor allOperations

111-- list of tags.

112-- list of tags.

112applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

113applyTagsFor ops ts swag = swag

114applyTagsFor ops ts swag = swag

114− & ops . tags %~ (<> Set.fromList (map _tagName ts))

115+ & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))

115− & tags %~ (<> Set.fromList ts)

116+ & tags %~ (<> InsOrdHS.fromList ts)

116

117

117-- | Construct a response with @'Schema'@ while declaring all

118-- | Construct a response with @'Schema'@ while declaring all

118-- necessary schema definitions.

119-- necessary schema definitions.

119--

120--

120-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

121-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

122-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

122−declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

123+declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response

123declareResponse proxy = do

124declareResponse proxy = do

124 s <- declareSchemaRef proxy

125 s <- declareSchemaRef proxy

125 return (mempty & schema ?~ s)

126 return (mempty & schema ?~ s)

@@ -190,4 +191,3 @@ setResponseForWith ops f code dres swag = swag

190 Nothing -> new -- response name can't be dereferenced, replacing with new response

191 Nothing -> new -- response name can't be dereferenced, replacing with new response

191 combine (Just (Inline old)) = f old new

192 combine (Just (Inline old)) = f old new

192 combine Nothing = new

193 combine Nothing = new

193−

src/Data/Swagger/Optics.hsnew file+597

@@ -0,0 +1,597 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE OverloadedLabels #-}

5+{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE UndecidableInstances #-}

8+{-# OPTIONS_GHC -fno-warn-orphans #-}

9+-- |

10+-- Module: Data.Swagger.Optics

11+-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>

12+-- Stability: experimental

13+--

14+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>

15+-- library.

16+--

17+-- >>> import Data.Aeson

18+-- >>> import Optics.Core

19+-- >>> :set -XOverloadedLabels

20+--

21+-- Example from the "Data.Swagger" module using @optics@:

22+--

23+-- >>> :{

24+-- encode $ (mempty :: Swagger)

25+-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]

26+-- & #paths .~

27+-- [ ("/user", mempty & #get ?~ (mempty

28+-- & #produces ?~ MimeList ["application/json"]

29+-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))

30+-- & at 404 ?~ "User info not found")) ]

31+-- :}

32+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"

33+--

34+-- For convenience optics are defined as /labels/. It means that field accessor

35+-- names can be overloaded for different types. One such common field is

36+-- @#description@. Many components of a Swagger specification can have

37+-- descriptions, and you can use the same name for them:

38+--

39+-- >>> encode $ (mempty :: Response) & #description .~ "No content"

40+-- "{\"description\":\"No content\"}"

41+-- >>> :{

42+-- encode $ (mempty :: Schema)

43+-- & #type ?~ SwaggerBoolean

44+-- & #description ?~ "To be or not to be"

45+-- :}

46+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"

47+--

48+-- @'ParamSchema'@ is basically the /base schema specification/ and many types

49+-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively

50+-- made fields of the type that has it. For example, you can use @#type@ to

51+-- access @'SwaggerType'@ of @'Header'@ schema without having to use

52+-- @#paramSchema@:

53+--

54+-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber

55+-- "{\"type\":\"number\"}"

56+--

57+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and

58+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:

59+--

60+-- >>> :{

61+-- encode $ (mempty :: Operation)

62+-- & at 404 ?~ "Not found"

63+-- :}

64+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"

65+--

66+module Data.Swagger.Optics () where

67+

68+import Data.Aeson (Value)

69+import Data.Scientific (Scientific)

70+import Data.Swagger.Internal

71+import Data.Text (Text)

72+import Optics.Core

73+import Optics.TH

74+

75+-- Lenses

76+

77+makeFieldLabels ''Swagger

78+makeFieldLabels ''Host

79+makeFieldLabels ''Info

80+makeFieldLabels ''Contact

81+makeFieldLabels ''License

82+makeFieldLabels ''PathItem

83+makeFieldLabels ''Tag

84+makeFieldLabels ''Operation

85+makeFieldLabels ''Param

86+makeFieldLabels ''ParamOtherSchema

87+makeFieldLabels ''Header

88+makeFieldLabels ''Schema

89+makeFieldLabels ''NamedSchema

90+makeFieldLabels ''ParamSchema

91+makeFieldLabels ''Xml

92+makeFieldLabels ''Responses

93+makeFieldLabels ''Response

94+makeFieldLabels ''SecurityScheme

95+makeFieldLabels ''ApiKeyParams

96+makeFieldLabels ''OAuth2Params

97+makeFieldLabels ''ExternalDocs

98+

99+-- Prisms

100+

101+makePrismLabels ''ParamAnySchema

102+makePrismLabels ''SecuritySchemeType

103+makePrismLabels ''Referenced

104+

105+-- SwaggerItems prisms

106+

107+instance

108+ ( a ~ [Referenced Schema]

109+ , b ~ [Referenced Schema]

110+ ) => LabelOptic "_SwaggerItemsArray"

111+ A_Review

112+ (SwaggerItems 'SwaggerKindSchema)

113+ (SwaggerItems 'SwaggerKindSchema)

114+ a

115+ b where

116+ labelOptic = unto (\x -> SwaggerItemsArray x)

117+ {-# INLINE labelOptic #-}

118+

119+instance

120+ ( a ~ Referenced Schema

121+ , b ~ Referenced Schema

122+ ) => LabelOptic "_SwaggerItemsObject"

123+ A_Review

124+ (SwaggerItems 'SwaggerKindSchema)

125+ (SwaggerItems 'SwaggerKindSchema)

126+ a

127+ b where

128+ labelOptic = unto (\x -> SwaggerItemsObject x)

129+ {-# INLINE labelOptic #-}

130+

131+instance

132+ ( a ~ (Maybe (CollectionFormat t), ParamSchema t)

133+ , b ~ (Maybe (CollectionFormat t), ParamSchema t)

134+ ) => LabelOptic "_SwaggerItemsPrimitive"

135+ A_Review

136+ (SwaggerItems t)

137+ (SwaggerItems t)

138+ a

139+ b where

140+ labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)

141+ {-# INLINE labelOptic #-}

142+

143+-- =============================================================

144+-- More helpful instances for easier access to schema properties

145+

146+type instance Index Responses = HttpStatusCode

147+type instance Index Operation = HttpStatusCode

148+

149+type instance IxValue Responses = Referenced Response

150+type instance IxValue Operation = Referenced Response

151+

152+instance Ixed Responses where

153+ ix n = #responses % ix n

154+ {-# INLINE ix #-}

155+instance At Responses where

156+ at n = #responses % at n

157+ {-# INLINE at #-}

158+

159+instance Ixed Operation where

160+ ix n = #responses % ix n

161+ {-# INLINE ix #-}

162+instance At Operation where

163+ at n = #responses % at n

164+ {-# INLINE at #-}

165+

166+-- #paramSchema

167+

168+instance

169+ ( a ~ ParamSchema 'SwaggerKindSchema

170+ , b ~ ParamSchema 'SwaggerKindSchema

171+ ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where

172+ labelOptic = #schema % #paramSchema

173+ {-# INLINE labelOptic #-}

174+

175+-- #type

176+

177+instance

178+ ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

179+ , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

180+ ) => LabelOptic "type" A_Lens Header Header a b where

181+ labelOptic = #paramSchema % #type

182+ {-# INLINE labelOptic #-}

183+

184+instance

185+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

186+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

187+ ) => LabelOptic "type" A_Lens Schema Schema a b where

188+ labelOptic = #paramSchema % #type

189+ {-# INLINE labelOptic #-}

190+

191+instance

192+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

193+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

194+ ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where

195+ labelOptic = #paramSchema % #type

196+ {-# INLINE labelOptic #-}

197+

198+instance

199+ ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

200+ , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

201+ ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where

202+ labelOptic = #paramSchema % #type

203+ {-# INLINE labelOptic #-}

204+

205+-- #default

206+

207+instance

208+ ( a ~ Maybe Value, b ~ Maybe Value

209+ ) => LabelOptic "default" A_Lens Header Header a b where

210+ labelOptic = #paramSchema % #default

211+ {-# INLINE labelOptic #-}

212+

213+instance

214+ ( a ~ Maybe Value, b ~ Maybe Value

215+ ) => LabelOptic "default" A_Lens Schema Schema a b where

216+ labelOptic = #paramSchema % #default

217+ {-# INLINE labelOptic #-}

218+

219+instance

220+ ( a ~ Maybe Value, b ~ Maybe Value

221+ ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where

222+ labelOptic = #paramSchema % #default

223+ {-# INLINE labelOptic #-}

224+

225+instance

226+ ( a ~ Maybe Value, b ~ Maybe Value

227+ ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where

228+ labelOptic = #paramSchema % #default

229+ {-# INLINE labelOptic #-}

230+

231+-- #format

232+

233+instance

234+ ( a ~ Maybe Format, b ~ Maybe Format

235+ ) => LabelOptic "format" A_Lens Header Header a b where

236+ labelOptic = #paramSchema % #format

237+ {-# INLINE labelOptic #-}

238+

239+instance

240+ ( a ~ Maybe Format, b ~ Maybe Format

241+ ) => LabelOptic "format" A_Lens Schema Schema a b where

242+ labelOptic = #paramSchema % #format

243+ {-# INLINE labelOptic #-}

244+

245+instance

246+ ( a ~ Maybe Format, b ~ Maybe Format

247+ ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where

248+ labelOptic = #paramSchema % #format

249+ {-# INLINE labelOptic #-}

250+

251+instance

252+ ( a ~ Maybe Format, b ~ Maybe Format

253+ ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where

254+ labelOptic = #paramSchema % #format

255+ {-# INLINE labelOptic #-}

256+

257+-- #items

258+

259+instance

260+ ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

261+ , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

262+ ) => LabelOptic "items" A_Lens Header Header a b where

263+ labelOptic = #paramSchema % #items

264+ {-# INLINE labelOptic #-}

265+

266+instance

267+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

268+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

269+ ) => LabelOptic "items" A_Lens Schema Schema a b where

270+ labelOptic = #paramSchema % #items

271+ {-# INLINE labelOptic #-}

272+

273+instance

274+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

275+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

276+ ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where

277+ labelOptic = #paramSchema % #items

278+ {-# INLINE labelOptic #-}

279+

280+instance

281+ ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

282+ , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

283+ ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where

284+ labelOptic = #paramSchema % #items

285+ {-# INLINE labelOptic #-}

286+

287+-- #maximum

288+

289+instance

290+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

291+ ) => LabelOptic "maximum" A_Lens Header Header a b where

292+ labelOptic = #paramSchema % #maximum

293+ {-# INLINE labelOptic #-}

294+

295+instance

296+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

297+ ) => LabelOptic "maximum" A_Lens Schema Schema a b where

298+ labelOptic = #paramSchema % #maximum

299+ {-# INLINE labelOptic #-}

300+

301+instance

302+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

303+ ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where

304+ labelOptic = #paramSchema % #maximum

305+ {-# INLINE labelOptic #-}

306+

307+instance

308+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

309+ ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

310+ labelOptic = #paramSchema % #maximum

311+ {-# INLINE labelOptic #-}

312+

313+-- #exclusiveMaximum

314+

315+instance

316+ ( a ~ Maybe Bool, b ~ Maybe Bool

317+ ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where

318+ labelOptic = #paramSchema % #exclusiveMaximum

319+ {-# INLINE labelOptic #-}

320+

321+instance

322+ ( a ~ Maybe Bool, b ~ Maybe Bool

323+ ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where

324+ labelOptic = #paramSchema % #exclusiveMaximum

325+ {-# INLINE labelOptic #-}

326+

327+instance

328+ ( a ~ Maybe Bool, b ~ Maybe Bool

329+ ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where

330+ labelOptic = #paramSchema % #exclusiveMaximum

331+ {-# INLINE labelOptic #-}

332+

333+instance

334+ ( a ~ Maybe Bool, b ~ Maybe Bool

335+ ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

336+ labelOptic = #paramSchema % #exclusiveMaximum

337+ {-# INLINE labelOptic #-}

338+

339+-- #minimum

340+

341+instance

342+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

343+ ) => LabelOptic "minimum" A_Lens Header Header a b where

344+ labelOptic = #paramSchema % #minimum

345+ {-# INLINE labelOptic #-}

346+

347+instance

348+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

349+ ) => LabelOptic "minimum" A_Lens Schema Schema a b where

350+ labelOptic = #paramSchema % #minimum

351+ {-# INLINE labelOptic #-}

352+

353+instance

354+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

355+ ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where

356+ labelOptic = #paramSchema % #minimum

357+ {-# INLINE labelOptic #-}

358+

359+instance

360+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

361+ ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

362+ labelOptic = #paramSchema % #minimum

363+ {-# INLINE labelOptic #-}

364+

365+-- #exclusiveMinimum

366+

367+instance

368+ ( a ~ Maybe Bool, b ~ Maybe Bool

369+ ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where

370+ labelOptic = #paramSchema % #exclusiveMinimum

371+ {-# INLINE labelOptic #-}

372+

373+instance

374+ ( a ~ Maybe Bool, b ~ Maybe Bool

375+ ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where

376+ labelOptic = #paramSchema % #exclusiveMinimum

377+ {-# INLINE labelOptic #-}

378+

379+instance

380+ ( a ~ Maybe Bool, b ~ Maybe Bool

381+ ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where

382+ labelOptic = #paramSchema % #exclusiveMinimum

383+ {-# INLINE labelOptic #-}

384+

385+instance

386+ ( a ~ Maybe Bool, b ~ Maybe Bool

387+ ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

388+ labelOptic = #paramSchema % #exclusiveMinimum

389+ {-# INLINE labelOptic #-}

390+

391+-- #maxLength

392+

393+instance

394+ ( a ~ Maybe Integer, b ~ Maybe Integer

395+ ) => LabelOptic "maxLength" A_Lens Header Header a b where

396+ labelOptic = #paramSchema % #maxLength

397+ {-# INLINE labelOptic #-}

398+

399+instance

400+ ( a ~ Maybe Integer, b ~ Maybe Integer

401+ ) => LabelOptic "maxLength" A_Lens Schema Schema a b where

402+ labelOptic = #paramSchema % #maxLength

403+ {-# INLINE labelOptic #-}

404+

405+instance

406+ ( a ~ Maybe Integer, b ~ Maybe Integer

407+ ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where

408+ labelOptic = #paramSchema % #maxLength

409+ {-# INLINE labelOptic #-}

410+

411+instance

412+ ( a ~ Maybe Integer, b ~ Maybe Integer

413+ ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

414+ labelOptic = #paramSchema % #maxLength

415+ {-# INLINE labelOptic #-}

416+

417+-- #minLength

418+

419+instance

420+ ( a ~ Maybe Integer, b ~ Maybe Integer

421+ ) => LabelOptic "minLength" A_Lens Header Header a b where

422+ labelOptic = #paramSchema % #minLength

423+ {-# INLINE labelOptic #-}

424+

425+instance

426+ ( a ~ Maybe Integer, b ~ Maybe Integer

427+ ) => LabelOptic "minLength" A_Lens Schema Schema a b where

428+ labelOptic = #paramSchema % #minLength

429+ {-# INLINE labelOptic #-}

430+

431+instance

432+ ( a ~ Maybe Integer, b ~ Maybe Integer

433+ ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where

434+ labelOptic = #paramSchema % #minLength

435+ {-# INLINE labelOptic #-}

436+

437+instance

438+ ( a ~ Maybe Integer, b ~ Maybe Integer

439+ ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

440+ labelOptic = #paramSchema % #minLength

441+ {-# INLINE labelOptic #-}

442+

443+-- #pattern

444+

445+instance

446+ ( a ~ Maybe Text, b ~ Maybe Text

447+ ) => LabelOptic "pattern" A_Lens Header Header a b where

448+ labelOptic = #paramSchema % #pattern

449+ {-# INLINE labelOptic #-}

450+

451+instance

452+ ( a ~ Maybe Text, b ~ Maybe Text

453+ ) => LabelOptic "pattern" A_Lens Schema Schema a b where

454+ labelOptic = #paramSchema % #pattern

455+ {-# INLINE labelOptic #-}

456+

457+instance

458+ ( a ~ Maybe Text, b ~ Maybe Text

459+ ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where

460+ labelOptic = #paramSchema % #pattern

461+ {-# INLINE labelOptic #-}

462+

463+instance

464+ ( a ~ Maybe Text, b ~ Maybe Text

465+ ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where

466+ labelOptic = #paramSchema % #pattern

467+ {-# INLINE labelOptic #-}

468+

469+-- #maxItems

470+

471+instance

472+ ( a ~ Maybe Integer, b ~ Maybe Integer

473+ ) => LabelOptic "maxItems" A_Lens Header Header a b where

474+ labelOptic = #paramSchema % #maxItems

475+ {-# INLINE labelOptic #-}

476+

477+instance

478+ ( a ~ Maybe Integer, b ~ Maybe Integer

479+ ) => LabelOptic "maxItems" A_Lens Schema Schema a b where

480+ labelOptic = #paramSchema % #maxItems

481+ {-# INLINE labelOptic #-}

482+

483+instance

484+ ( a ~ Maybe Integer, b ~ Maybe Integer

485+ ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where

486+ labelOptic = #paramSchema % #maxItems

487+ {-# INLINE labelOptic #-}

488+

489+instance

490+ ( a ~ Maybe Integer, b ~ Maybe Integer

491+ ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

492+ labelOptic = #paramSchema % #maxItems

493+ {-# INLINE labelOptic #-}

494+

495+-- #minItems

496+

497+instance

498+ ( a ~ Maybe Integer, b ~ Maybe Integer

499+ ) => LabelOptic "minItems" A_Lens Header Header a b where

500+ labelOptic = #paramSchema % #minItems

501+ {-# INLINE labelOptic #-}

502+

503+instance

504+ ( a ~ Maybe Integer, b ~ Maybe Integer

505+ ) => LabelOptic "minItems" A_Lens Schema Schema a b where

506+ labelOptic = #paramSchema % #minItems

507+ {-# INLINE labelOptic #-}

508+

509+instance

510+ ( a ~ Maybe Integer, b ~ Maybe Integer

511+ ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where

512+ labelOptic = #paramSchema % #minItems

513+ {-# INLINE labelOptic #-}

514+

515+instance

516+ ( a ~ Maybe Integer, b ~ Maybe Integer

517+ ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

518+ labelOptic = #paramSchema % #minItems

519+ {-# INLINE labelOptic #-}

520+

521+-- #uniqueItems

522+

523+instance

524+ ( a ~ Maybe Bool, b ~ Maybe Bool

525+ ) => LabelOptic "uniqueItems" A_Lens Header Header a b where

526+ labelOptic = #paramSchema % #uniqueItems

527+ {-# INLINE labelOptic #-}

528+

529+instance

530+ ( a ~ Maybe Bool, b ~ Maybe Bool

531+ ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where

532+ labelOptic = #paramSchema % #uniqueItems

533+ {-# INLINE labelOptic #-}

534+

535+instance

536+ ( a ~ Maybe Bool, b ~ Maybe Bool

537+ ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where

538+ labelOptic = #paramSchema % #uniqueItems

539+ {-# INLINE labelOptic #-}

540+

541+instance

542+ ( a ~ Maybe Bool, b ~ Maybe Bool

543+ ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

544+ labelOptic = #paramSchema % #uniqueItems

545+ {-# INLINE labelOptic #-}

546+

547+-- #enum

548+

549+instance

550+ ( a ~ Maybe [Value], b ~ Maybe [Value]

551+ ) => LabelOptic "enum" A_Lens Header Header a b where

552+ labelOptic = #paramSchema % #enum

553+ {-# INLINE labelOptic #-}

554+

555+instance

556+ ( a ~ Maybe [Value], b ~ Maybe [Value]

557+ ) => LabelOptic "enum" A_Lens Schema Schema a b where

558+ labelOptic = #paramSchema % #enum

559+ {-# INLINE labelOptic #-}

560+

561+instance

562+ ( a ~ Maybe [Value], b ~ Maybe [Value]

563+ ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where

564+ labelOptic = #paramSchema % #enum

565+ {-# INLINE labelOptic #-}

566+

567+instance

568+ ( a ~ Maybe [Value], b ~ Maybe [Value]

569+ ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where

570+ labelOptic = #paramSchema % #enum

571+ {-# INLINE labelOptic #-}

572+

573+-- #multipleOf

574+

575+instance

576+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

577+ ) => LabelOptic "multipleOf" A_Lens Header Header a b where

578+ labelOptic = #paramSchema % #multipleOf

579+ {-# INLINE labelOptic #-}

580+

581+instance

582+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

583+ ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where

584+ labelOptic = #paramSchema % #multipleOf

585+ {-# INLINE labelOptic #-}

586+

587+instance

588+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

589+ ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where

590+ labelOptic = #paramSchema % #multipleOf

591+ {-# INLINE labelOptic #-}

592+

593+instance

594+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

595+ ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where

596+ labelOptic = #paramSchema % #multipleOf

597+ {-# INLINE labelOptic #-}

src/Data/Swagger/Schema.hs+11

@@ -17,8 +17,18 @@ module Data.Swagger.Schema (

17 -- * Generic schema encoding

18 genericDeclareNamedSchema,

19 genericDeclareSchema,

20+ genericDeclareNamedSchemaNewtype,

21+ genericNameSchema,

22+

23+ -- ** 'Bounded' 'Integral'

20 genericToNamedSchemaBoundedIntegral,

24 genericToNamedSchemaBoundedIntegral,

21 toSchemaBoundedIntegral,

25 toSchemaBoundedIntegral,

26+

27+ -- ** 'Bounded' 'Enum' key mappings

28+ declareSchemaBoundedEnumKeyMapping,

29+ toSchemaBoundedEnumKeyMapping,

30+

31+ -- ** Reusing 'ToParamSchema'

22 paramSchemaToNamedSchema,

32 paramSchemaToNamedSchema,

23 paramSchemaToSchema,

33 paramSchemaToSchema,

@@ -44,6 +54,7 @@ module Data.Swagger.Schema (

44 -- * Generic encoding configuration

54 -- * Generic encoding configuration

45 SchemaOptions(..),

55 SchemaOptions(..),

46 defaultSchemaOptions,

56 defaultSchemaOptions,

57+ fromAesonOptions,

47) where

58) where

49import Data.Swagger.Internal.Schema

60import Data.Swagger.Internal.Schema

src/Data/Swagger/Schema/Generator.hsnew file+114

@@ -0,0 +1,114 @@

1+{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE OverloadedLists #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

5+module Data.Swagger.Schema.Generator where

7+import Prelude ()

8+import Prelude.Compat

10+import Control.Lens.Operators

11+import Control.Monad (filterM)

12+import Data.Aeson

13+import Data.Aeson.Types

14+import qualified Data.HashMap.Strict.InsOrd as M

15+import Data.Maybe

16+import Data.Maybe

17+import Data.Proxy

18+import Data.Scientific

19+import qualified Data.Set as S

20+import Data.Swagger

21+import Data.Swagger.Declare

22+import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)

23+import qualified Data.Text as T

24+import qualified Data.Vector as V

25+import Test.QuickCheck (arbitrary)

26+import Test.QuickCheck.Gen

27+import Test.QuickCheck.Property

28+

29+-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30+-- and cannot be inferred.

31+schemaGen :: Definitions Schema -> Schema -> Gen Value

32+schemaGen _ schema

33+ | Just cases <- schema ^. paramSchema . enum_ = elements cases

34+schemaGen defns schema =

35+ case schema ^. type_ of

36+ Nothing ->

37+ case inferSchemaTypes schema of

38+ [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

39+ -- Gen is not MonadFail

40+ _ -> error "unable to infer schema type"

41+ Just SwaggerBoolean -> Bool <$> elements [True, False]

42+ Just SwaggerNull -> pure Null

43+ Just SwaggerNumber

44+ | Just min <- schema ^. minimum_

45+ , Just max <- schema ^. maximum_ ->

46+ Number . fromFloatDigits <$>

47+ choose (toRealFloat min, toRealFloat max :: Double)

48+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

49+ Just SwaggerInteger

50+ | Just min <- schema ^. minimum_

51+ , Just max <- schema ^. maximum_ ->

52+ Number . fromInteger <$>

53+ choose (truncate min, truncate max)

54+ | otherwise -> Number . fromInteger <$> arbitrary

55+ Just SwaggerArray

56+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

57+ | Just items <- schema ^. items ->

58+ case items of

59+ SwaggerItemsObject ref -> do

60+ size <- getSize

61+ let itemSchema = dereference defns ref

62+ minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems

63+ maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems

64+ arrayLength <- choose (minLength', max minLength' maxLength')

65+ generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema

66+ return . Array $ V.fromList generatedArray

67+ SwaggerItemsArray refs ->

68+ let itemGens = schemaGen defns . dereference defns <$> refs

69+ in fmap (Array . V.fromList) $ sequence itemGens

70+ Just SwaggerString -> do

71+ size <- getSize

72+ let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

73+ let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

74+ length <- choose (minLength', max minLength' maxLength')

75+ str <- vectorOf length arbitrary

76+ return . String $ T.pack str

77+ Just SwaggerObject -> do

78+ size <- getSize

79+ let props = dereference defns <$> schema ^. properties

80+ reqKeys = S.fromList $ schema ^. required

81+ allKeys = S.fromList . M.keys $ schema ^. properties

82+ optionalKeys = allKeys S.\\ reqKeys

83+ minProps' = fromMaybe (length reqKeys) $

84+ fromInteger <$> schema ^. minProperties

85+ maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties

86+ shuffledOptional <- shuffle $ S.toList optionalKeys

87+ numProps <- choose (minProps', max minProps' maxProps')

88+ let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional

89+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props

90+ let gens = schemaGen defns <$> presentProps

91+ additionalGens <- case schema ^. additionalProperties of

92+ Just (AdditionalPropertiesSchema addlSchema) -> do

93+ additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary

94+ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

95+ _ -> return []

96+ x <- sequence $ gens <> additionalGens

97+ return . Object $ M.toHashMap x

98+ where

99+ dereference :: Definitions a -> Referenced a -> a

100+ dereference _ (Inline a) = a

101+ dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

102+

103+genValue :: (ToSchema a) => Proxy a -> Gen Value

104+genValue p =

105+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty

106+ in schemaGen defs schema

107+

108+validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property

109+validateFromJSON p = forAll (genValue p) $

110+ \val -> case parseEither parseJSON val of

111+ Right (_ :: a) -> succeeded

112+ Left err -> failed

113+ { reason = err

114+ }

src/Data/Swagger/Schema/Validation.hs+10−1

@@ -15,9 +15,18 @@ module Data.Swagger.Schema.Validation (

15 -- $maybe

17 -- * JSON validation

18+

19+ ValidationError,

20+

21+ -- ** Using 'ToJSON' and 'ToSchema'

22+ validatePrettyToJSON,

18 validateToJSON,

23 validateToJSON,

19 validateToJSONWithPatternChecker,

24 validateToJSONWithPatternChecker,

20− ValidationError,

25+ renderValidationErrors,

26+

27+ -- ** Using 'Value' and 'Schema'

28+ validateJSON,

29+ validateJSONWithPatternChecker,

21) where

30) where

23import Data.Swagger.Internal.Schema.Validation

32import Data.Swagger.Internal.Schema.Validation

src/Data/Swagger/SchemaOptions.hs+29

@@ -1,3 +1,4 @@

1+{-# LANGUAGE RecordWildCards #-}

1-- |

2-- |

2-- Module: Data.Swagger.SchemaOptions

3-- Module: Data.Swagger.SchemaOptions

3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

4-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

@@ -6,6 +7,8 @@

6-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.

7-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.

7module Data.Swagger.SchemaOptions where

8module Data.Swagger.SchemaOptions where

10+import qualified Data.Aeson.Types as Aeson

11+

9-- | Options that specify how to encode your type to Swagger schema.

12-- | Options that specify how to encode your type to Swagger schema.

10data SchemaOptions = SchemaOptions

13data SchemaOptions = SchemaOptions

11 { -- | Function applied to field labels. Handy for removing common record prefixes for example.

14 { -- | Function applied to field labels. Handy for removing common record prefixes for example.

@@ -41,3 +44,29 @@ defaultSchemaOptions = SchemaOptions

41 , unwrapUnaryRecords = False

44 , unwrapUnaryRecords = False

42 }

45 }

47+-- | Convert 'Aeson.Options' to 'SchemaOptions'.

48+--

49+-- Specifically the following fields get copied:

50+--

51+-- * 'fieldLabelModifier'

52+-- * 'constructorTagModifier'

53+-- * 'allNullaryToStringTag'

54+-- * 'unwrapUnaryRecords'

55+--

56+-- Note that these fields have no effect on `SchemaOptions`:

57+--

58+-- * 'Aeson.omitNothingFields'

59+-- * 'Aeson.sumEncoding'

60+-- * 'Aeson.tagSingleConstructors'

61+--

62+-- The rest is defined as in 'defaultSchemaOptions'.

63+--

64+-- @since 2.2.1

65+--

66+fromAesonOptions :: Aeson.Options -> SchemaOptions

67+fromAesonOptions opts = defaultSchemaOptions

68+ { fieldLabelModifier = Aeson.fieldLabelModifier opts

69+ , constructorTagModifier = Aeson.constructorTagModifier opts

70+ , allNullaryToStringTag = Aeson.allNullaryToStringTag opts

71+ , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts

72+ }

stack-ghc-8.0.yamldeleted−5

@@ -1,5 +0,0 @@

1−resolver: nightly-2016-05-29

2−packages:

3−- '.'

4−extra-deps:

5− - aeson-0.11.2.1

stack-lts-2.yamldeleted−22

@@ -1,22 +0,0 @@

1−flags: {}

2−packages:

3−- '.'

4−extra-deps:

5−- aeson-0.11.2.1

6−- attoparsec-0.13.1.0

7−- base-compat-0.9.1

8−- fail-4.9.0.0

9−- generics-sop-0.2.1.0

10−- insert-ordered-containers-0.1.0.1

11−- primitive-0.6.1.0

12−- QuickCheck-2.8.2

13−- tagged-0.8.4

14−- unordered-containers-0.2.7.0

15−resolver: lts-2.22

16−flags:

17− aeson:

18− old-locale: true

19− QuickCheck:

20− base3: false

21− base4: true

22− base4point8: false

stack.yaml+7−1

@@ -1,3 +1,9 @@

1−resolver: lts-8.0

1+resolver: lts-14.3

2packages:

3- '.'

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

swagger2.cabal+84−48

@@ -1,11 +1,15 @@

1+cabal-version: >=1.10

1name: swagger2

2name: swagger2

2−version: 2.1.4.1

3+version: 2.5

3synopsis: Swagger 2.0 data model

5synopsis: Swagger 2.0 data model

6+category: Web, Swagger

4description:

7description:

5− This library is inteded to be used for decoding and encoding Swagger 2.0 API

8+ This library is intended to be used for decoding and encoding Swagger 2.0 API

6 specifications as well as manipulating them.

9 specifications as well as manipulating them.

7 .

10 .

8 The original Swagger 2.0 specification is available at http://swagger.io/specification/.

11 The original Swagger 2.0 specification is available at http://swagger.io/specification/.

12+

9homepage: https://github.com/GetShopTV/swagger2

13homepage: https://github.com/GetShopTV/swagger2

10bug-reports: https://github.com/GetShopTV/swagger2/issues

14bug-reports: https://github.com/GetShopTV/swagger2/issues

11license: BSD3

15license: BSD3

@@ -13,19 +17,22 @@ license-file: LICENSE

13author: Nickolay Kudasov

17author: Nickolay Kudasov

14maintainer: nickolay@getshoptv.com

18maintainer: nickolay@getshoptv.com

16−category: Web, Swagger

17build-type: Custom

20build-type: Custom

18extra-source-files:

21extra-source-files:

19 README.md

22 README.md

20 , CHANGELOG.md

23 , CHANGELOG.md

21 , examples/*.hs

24 , examples/*.hs

22 , include/overlapping-compat.h

25 , include/overlapping-compat.h

23−cabal-version: >=1.10

24−tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1

26+tested-with:

27+ GHC ==8.0.2

28+ || ==8.2.2

29+ || ==8.4.4

30+ || ==8.6.5

31+ || ==8.8.1

26custom-setup

33custom-setup

27 setup-depends:

34 setup-depends:

28− base, Cabal, cabal-doctest >=1.0.2 && <1.1

35+ base, Cabal, cabal-doctest >=1.0.6 && <1.1

30library

37library

31 hs-source-dirs: src

38 hs-source-dirs: src

@@ -35,8 +42,10 @@ library

35 Data.Swagger.Declare

42 Data.Swagger.Declare

36 Data.Swagger.Lens

43 Data.Swagger.Lens

37 Data.Swagger.Operation

44 Data.Swagger.Operation

45+ Data.Swagger.Optics

38 Data.Swagger.ParamSchema

46 Data.Swagger.ParamSchema

39 Data.Swagger.Schema

47 Data.Swagger.Schema

48+ Data.Swagger.Schema.Generator

40 Data.Swagger.Schema.Validation

49 Data.Swagger.Schema.Validation

41 Data.Swagger.SchemaOptions

50 Data.Swagger.SchemaOptions

@@ -48,62 +57,89 @@ library

48 Data.Swagger.Internal.Utils

57 Data.Swagger.Internal.Utils

49 Data.Swagger.Internal.AesonUtils

58 Data.Swagger.Internal.AesonUtils

50 Data.Swagger.Internal.TypeShape

59 Data.Swagger.Internal.TypeShape

60+

61+ -- GHC boot libraries

51− build-depends: base >=4.7 && <4.11

62+ build-depends:

52− , base-compat >=0.9.1 && <0.10

63+ base >=4.9 && <4.14

53− , aeson >=0.11.2.1

64+ , aeson-pretty >=0.8.7 && <0.9

54− , bytestring

65+ , bytestring >=0.10.4.0 && <0.11

55− , containers

66+ , containers >=0.5.5.1 && <0.7

56− , hashable

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

57− , generics-sop >=0.2 && <0.4

81+ , generics-sop >=0.3.2.0 && <0.6

82+ , hashable >=1.2.7.0 && <1.4

58− , http-media

83+ , http-media >=0.7.1.2 && <0.9

59− , insert-ordered-containers >=0.1.0.0 && <0.3

84+ , insert-ordered-containers >=0.2.3 && <0.3

60− , lens

85+ , lens >=4.16.1 && <4.19

61− , mtl

62− , network

86+ , network >=2.6.3.5 && <3.2

87+ , optics-core >=0.2 && <0.3

88+ , optics-th >=0.2 && <0.3

63− , scientific

89+ , scientific >=0.3.6.2 && <0.4

64− , text

65− , template-haskell

66− , time

67− , transformers

68− , transformers-compat >= 0.3

90+ , transformers-compat >=0.3 && <0.7

69− , unordered-containers

91+ , unordered-containers >=0.2.9.0 && <0.3

70− , vector

71− , uuid-types >=1.0.2 && <1.1

92+ , uuid-types >=1.0.3 && <1.1

93+ , vector >=0.12.0.1 && <0.13

94+ , QuickCheck >=2.10.1 && <2.14

95+

72 default-language: Haskell2010

96 default-language: Haskell2010

74test-suite spec

98test-suite spec

75 type: exitcode-stdio-1.0

99 type: exitcode-stdio-1.0

76 hs-source-dirs: test

100 hs-source-dirs: test

77 main-is: Spec.hs

101 main-is: Spec.hs

102+

103+ -- From library parat

78 -- We need aeson's toEncoding for doctests too

104 -- We need aeson's toEncoding for doctests too

79− build-depends: base

105+ build-depends:

106+ base

107+ , swagger2

108+ , aeson

80− , base-compat

109+ , base-compat-batteries

81− , aeson >=0.10.0.0

82− , aeson-qq

83− , bytestring

110+ , bytestring

84− , containers

111+ , containers

85− , hashable

112+ , hashable

86− , hspec

87− , insert-ordered-containers

113+ , insert-ordered-containers

88− , HUnit

114+ , lens

89− , mtl

115+ , mtl

90− , QuickCheck >=2.8.2

116+ , template-haskell

91− , swagger2

92− , text

117+ , text

93− , time

118+ , time

94− , unordered-containers

119+ , unordered-containers

95− , vector

120+ , vector

96− , lens

121+ , QuickCheck

122+

123+ -- test-suite only dependencies

124+ build-depends:

125+ hspec >=2.5.5 && <2.8

126+ , HUnit >=1.6.0.0 && <1.7

127+ , quickcheck-instances >=0.3.19 && <0.14

128+ , utf8-string >=1.0.1.1 && <1.1

129+

130+ -- https://github.com/haskell/cabal/issues/3708

131+ build-tool-depends:

132+ hspec-discover:hspec-discover >=2.5.5 && <2.8

133+

97 other-modules:

134 other-modules:

98 SpecCommon

135 SpecCommon

99 Data.SwaggerSpec

136 Data.SwaggerSpec

137+ Data.Swagger.CommonTestTypes

100 Data.Swagger.ParamSchemaSpec

138 Data.Swagger.ParamSchemaSpec

101 Data.Swagger.SchemaSpec

139 Data.Swagger.SchemaSpec

102 Data.Swagger.Schema.ValidationSpec

140 Data.Swagger.Schema.ValidationSpec

141+ Data.Swagger.Schema.GeneratorSpec

103 default-language: Haskell2010

142 default-language: Haskell2010

104− -- https://github.com/haskell/cabal/issues/3708

105− build-tool-depends:

106− hspec-discover:hspec-discover

107

143

108test-suite doctests

144test-suite doctests

109 -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes

145 -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes

test/Data/Swagger/CommonTestTypes.hsnew file+679

@@ -0,0 +1,679 @@

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE QuasiQuotes #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

5+module Data.Swagger.CommonTestTypes where

7+import Prelude ()

8+import Prelude.Compat

10+import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)

11+import Data.Aeson.QQ.Simple

12+import Data.Aeson.Types (toJSONKeyText)

13+import Data.Char

14+import Data.Map (Map)

15+import Data.Proxy

16+import Data.Set (Set)

17+import qualified Data.Text as Text

18+import GHC.Generics

19+

20+import Data.Swagger

21+

22+-- ========================================================================

23+-- Unit type

24+-- ========================================================================

25+

26+data Unit = Unit deriving (Generic)

27+instance ToParamSchema Unit

28+instance ToSchema Unit

29+

30+unitSchemaJSON :: Value

31+unitSchemaJSON = [aesonQQ|

32+{

33+ "type": "string",

34+ "enum": ["Unit"]

35+}

36+|]

37+

38+-- ========================================================================

39+-- Color (enum)

40+-- ========================================================================

41+data Color

42+ = Red

43+ | Green

44+ | Blue

45+ deriving (Generic)

46+instance ToParamSchema Color

47+instance ToSchema Color

48+

49+colorSchemaJSON :: Value

50+colorSchemaJSON = [aesonQQ|

51+{

52+ "type": "string",

53+ "enum": ["Red", "Green", "Blue"]

54+}

55+|]

56+

57+-- ========================================================================

58+-- Shade (paramSchemaToNamedSchema)

59+-- ========================================================================

60+

61+data Shade = Dim | Bright deriving (Generic)

62+instance ToParamSchema Shade

63+

64+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions

65+

66+shadeSchemaJSON :: Value

67+shadeSchemaJSON = [aesonQQ|

68+{

69+ "type": "string",

70+ "enum": ["Dim", "Bright"]

71+}

72+|]

73+

74+-- ========================================================================

75+-- Paint (record with bounded enum property)

76+-- ========================================================================

77+

78+newtype Paint = Paint { color :: Color }

79+ deriving (Generic)

80+instance ToSchema Paint

81+

82+paintSchemaJSON :: Value

83+paintSchemaJSON = [aesonQQ|

84+{

85+ "type": "object",

86+ "properties":

87+ {

88+ "color":

89+ {

90+ "$ref": "#/definitions/Color"

91+ }

92+ },

93+ "required": ["color"]

94+}

95+|]

96+

97+paintInlinedSchemaJSON :: Value

98+paintInlinedSchemaJSON = [aesonQQ|

99+{

100+ "type": "object",

101+ "properties":

102+ {

103+ "color":

104+ {

105+ "type": "string",

106+ "enum": ["Red", "Green", "Blue"]

107+ }

108+ },

109+ "required": ["color"]

110+}

111+|]

112+

113+-- ========================================================================

114+-- Status (constructorTagModifier)

115+-- ========================================================================

116+

117+data Status

118+ = StatusOk

119+ | StatusError

120+ deriving (Generic)

121+

122+instance ToParamSchema Status where

123+ toParamSchema = genericToParamSchema defaultSchemaOptions

124+ { constructorTagModifier = map toLower . drop (length "Status") }

125+instance ToSchema Status where

126+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

127+ { constructorTagModifier = map toLower . drop (length "Status") }

128+

129+statusSchemaJSON :: Value

130+statusSchemaJSON = [aesonQQ|

131+{

132+ "type": "string",

133+ "enum": ["ok", "error"]

134+}

135+|]

136+

137+-- ========================================================================

138+-- Email (newtype with unwrapUnaryRecords set to True)

139+-- ========================================================================

140+

141+newtype Email = Email { getEmail :: String }

142+ deriving (Generic)

143+instance ToParamSchema Email

144+instance ToSchema Email where

145+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

146+ { unwrapUnaryRecords = True }

147+

148+emailSchemaJSON :: Value

149+emailSchemaJSON = [aesonQQ|

150+{

151+ "type": "string"

152+}

153+|]

154+

155+-- ========================================================================

156+-- UserId (non-record newtype)

157+-- ========================================================================

158+

159+newtype UserId = UserId Integer

160+ deriving (Eq, Ord, Generic)

161+instance ToParamSchema UserId

162+instance ToSchema UserId

163+

164+userIdSchemaJSON :: Value

165+userIdSchemaJSON = [aesonQQ|

166+{

167+ "type": "integer"

168+}

169+|]

170+

171+-- ========================================================================

172+-- UserGroup (set newtype)

173+-- ========================================================================

174+

175+newtype UserGroup = UserGroup (Set UserId)

176+ deriving (Generic)

177+instance ToSchema UserGroup

178+

179+userGroupSchemaJSON :: Value

180+userGroupSchemaJSON = [aesonQQ|

181+{

182+ "type": "array",

183+ "items": { "$ref": "#/definitions/UserId" },

184+ "uniqueItems": true

185+}

186+|]

187+

188+-- ========================================================================

189+-- Person (simple record with optional fields)

190+-- ========================================================================

191+data Person = Person

192+ { name :: String

193+ , phone :: Integer

194+ , email :: Maybe String

195+ } deriving (Generic)

196+

197+instance ToSchema Person

198+

199+personSchemaJSON :: Value

200+personSchemaJSON = [aesonQQ|

201+{

202+ "type": "object",

203+ "properties":

204+ {

205+ "name": { "type": "string" },

206+ "phone": { "type": "integer" },

207+ "email": { "type": "string" }

208+ },

209+ "required": ["name", "phone"]

210+}

211+|]

212+

213+-- ========================================================================

214+-- Player (record newtype)

215+-- ========================================================================

216+

217+newtype Player = Player

218+ { position :: Point

219+ } deriving (Generic)

220+instance ToSchema Player

221+

222+playerSchemaJSON :: Value

223+playerSchemaJSON = [aesonQQ|

224+{

225+ "type": "object",

226+ "properties":

227+ {

228+ "position":

229+ {

230+ "$ref": "#/definitions/Point"

231+ }

232+ },

233+ "required": ["position"]

234+}

235+|]

236+

237+newtype Players = Players [Inlined Player]

238+ deriving (Generic)

239+instance ToSchema Players

240+

241+playersSchemaJSON :: Value

242+playersSchemaJSON = [aesonQQ|

243+{

244+ "type": "array",

245+ "items":

246+ {

247+ "type": "object",

248+ "properties":

249+ {

250+ "position":

251+ {

252+ "$ref": "#/definitions/Point"

253+ }

254+ },

255+ "required": ["position"]

256+ }

257+}

258+|]

259+

260+-- ========================================================================

261+-- Character (sum type with ref and record in alternative)

262+-- ========================================================================

263+

264+data Character

265+ = PC Player

266+ | NPC { npcName :: String, npcPosition :: Point }

267+ deriving (Generic)

268+instance ToSchema Character

269+

270+characterSchemaJSON :: Value

271+characterSchemaJSON = [aesonQQ|

272+{

273+ "type": "object",

274+ "properties":

275+ {

276+ "PC": { "$ref": "#/definitions/Player" },

277+ "NPC":

278+ {

279+ "type": "object",

280+ "properties":

281+ {

282+ "npcName": { "type": "string" },

283+ "npcPosition": { "$ref": "#/definitions/Point" }

284+ },

285+ "required": ["npcName", "npcPosition"]

286+ }

287+ },

288+ "maxProperties": 1,

289+ "minProperties": 1

290+}

291+|]

292+

293+characterInlinedSchemaJSON :: Value

294+characterInlinedSchemaJSON = [aesonQQ|

295+{

296+ "type": "object",

297+ "properties":

298+ {

299+ "PC":

300+ {

301+ "type": "object",

302+ "properties":

303+ {

304+ "position":

305+ {

306+ "type": "object",

307+ "properties":

308+ {

309+ "x": { "type": "number", "format": "double" },

310+ "y": { "type": "number", "format": "double" }

311+ },

312+ "required": ["x", "y"]

313+ }

314+ },

315+ "required": ["position"]

316+ },

317+ "NPC":

318+ {

319+ "type": "object",

320+ "properties":

321+ {

322+ "npcName": { "type": "string" },

323+ "npcPosition":

324+ {

325+ "type": "object",

326+ "properties":

327+ {

328+ "x": { "type": "number", "format": "double" },

329+ "y": { "type": "number", "format": "double" }

330+ },

331+ "required": ["x", "y"]

332+ }

333+ },

334+ "required": ["npcName", "npcPosition"]

335+ }

336+ },

337+ "maxProperties": 1,

338+ "minProperties": 1

339+}

340+|]

341+

342+characterInlinedPlayerSchemaJSON :: Value

343+characterInlinedPlayerSchemaJSON = [aesonQQ|

344+{

345+ "type": "object",

346+ "properties":

347+ {

348+ "PC":

349+ {

350+ "type": "object",

351+ "properties":

352+ {

353+ "position":

354+ {

355+ "$ref": "#/definitions/Point"

356+ }

357+ },

358+ "required": ["position"]

359+ },

360+ "NPC":

361+ {

362+ "type": "object",

363+ "properties":

364+ {

365+ "npcName": { "type": "string" },

366+ "npcPosition": { "$ref": "#/definitions/Point" }

367+ },

368+ "required": ["npcName", "npcPosition"]

369+ }

370+ },

371+ "maxProperties": 1,

372+ "minProperties": 1

373+}

374+|]

375+

376+-- ========================================================================

377+-- ISPair (non-record product data type)

378+-- ========================================================================

379+data ISPair = ISPair Integer String

380+ deriving (Generic)

381+

382+instance ToSchema ISPair

383+

384+ispairSchemaJSON :: Value

385+ispairSchemaJSON = [aesonQQ|

386+{

387+ "type": "array",

388+ "items":

389+ [

390+ { "type": "integer" },

391+ { "type": "string" }

392+ ],

393+ "minItems": 2,

394+ "maxItems": 2

395+}

396+|]

397+

398+-- ========================================================================

399+-- Point (record data type with custom fieldLabelModifier)

400+-- ========================================================================

401+

402+data Point = Point

403+ { pointX :: Double

404+ , pointY :: Double

405+ } deriving (Generic)

406+

407+instance ToSchema Point where

408+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

409+ { fieldLabelModifier = map toLower . drop (length "point") }

410+

411+pointSchemaJSON :: Value

412+pointSchemaJSON = [aesonQQ|

413+{

414+ "type": "object",

415+ "properties":

416+ {

417+ "x": { "type": "number", "format": "double" },

418+ "y": { "type": "number", "format": "double" }

419+ },

420+ "required": ["x", "y"]

421+}

422+|]

423+

424+-- ========================================================================

425+-- Point (record data type with multiple fields)

426+-- ========================================================================

427+

428+data Point5 = Point5

429+ { point5X :: Double

430+ , point5Y :: Double

431+ , point5Z :: Double

432+ , point5U :: Double

433+ , point5V :: Double -- 5 dimensional!

434+ } deriving (Generic)

435+

436+instance ToSchema Point5 where

437+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

438+ { fieldLabelModifier = map toLower . drop (length "point5") }

439+

440+point5SchemaJSON :: Value

441+point5SchemaJSON = [aesonQQ|

442+{

443+ "type": "object",

444+ "properties":

445+ {

446+ "x": { "type": "number", "format": "double" },

447+ "y": { "type": "number", "format": "double" },

448+ "z": { "type": "number", "format": "double" },

449+ "u": { "type": "number", "format": "double" },

450+ "v": { "type": "number", "format": "double" }

451+ },

452+ "required": ["x", "y", "z", "u", "v"]

453+}

454+|]

455+

456+point5Properties :: [String]

457+point5Properties = ["x", "y", "z", "u", "v"]

458+

459+-- ========================================================================

460+-- MyRoseTree (custom datatypeNameModifier)

461+-- ========================================================================

462+

463+data MyRoseTree = MyRoseTree

464+ { root :: String

465+ , trees :: [MyRoseTree]

466+ } deriving (Generic)

467+

468+instance ToSchema MyRoseTree where

469+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

470+ { datatypeNameModifier = drop (length "My") }

471+

472+myRoseTreeSchemaJSON :: Value

473+myRoseTreeSchemaJSON = [aesonQQ|

474+{

475+ "type": "object",

476+ "properties":

477+ {

478+ "root": { "type": "string" },

479+ "trees":

480+ {

481+ "type": "array",

482+ "items":

483+ {

484+ "$ref": "#/definitions/RoseTree"

485+ }

486+ }

487+ },

488+ "required": ["root", "trees"]

489+}

490+|]

491+

492+data MyRoseTree' = MyRoseTree'

493+ { root' :: String

494+ , trees' :: [MyRoseTree']

495+ } deriving (Generic)

496+

497+instance ToSchema MyRoseTree' where

498+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

499+ { datatypeNameModifier = map toLower }

500+

501+myRoseTreeSchemaJSON' :: Value

502+myRoseTreeSchemaJSON' = [aesonQQ|

503+{

504+ "type": "object",

505+ "properties":

506+ {

507+ "root'": { "type": "string" },

508+ "trees'":

509+ {

510+ "type": "array",

511+ "items":

512+ {

513+ "$ref": "#/definitions/myrosetree'"

514+ }

515+ }

516+ },

517+ "required": ["root'", "trees'"]

518+}

519+|]

520+

521+-- ========================================================================

522+-- Inlined (newtype for inlining schemas)

523+-- ========================================================================

524+

525+newtype Inlined a = Inlined { getInlined :: a }

526+

527+instance ToSchema a => ToSchema (Inlined a) where

528+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

529+ where

530+ unname (NamedSchema _ s) = NamedSchema Nothing s

531+

532+-- ========================================================================

533+-- Light (sum type with unwrapUnaryRecords)

534+-- ========================================================================

535+

536+data Light

537+ = NoLight

538+ | LightFreq Double

539+ | LightColor Color

540+ | LightWaveLength { waveLength :: Double }

541+ deriving (Generic)

542+

543+instance ToSchema Light where

544+ declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

545+ { unwrapUnaryRecords = True }

546+

547+lightSchemaJSON :: Value

548+lightSchemaJSON = [aesonQQ|

549+{

550+ "type": "object",

551+ "properties":

552+ {

553+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

554+ "LightFreq": { "type": "number", "format": "double" },

555+ "LightColor": { "$ref": "#/definitions/Color" },

556+ "LightWaveLength": { "type": "number", "format": "double" }

557+ },

558+ "maxProperties": 1,

559+ "minProperties": 1

560+}

561+|]

562+

563+lightInlinedSchemaJSON :: Value

564+lightInlinedSchemaJSON = [aesonQQ|

565+{

566+ "type": "object",

567+ "properties":

568+ {

569+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

570+ "LightFreq": { "type": "number", "format": "double" },

571+ "LightColor":

572+ {

573+ "type": "string",

574+ "enum": ["Red", "Green", "Blue"]

575+ },

576+ "LightWaveLength": { "type": "number", "format": "double" }

577+ },

578+ "maxProperties": 1,

579+ "minProperties": 1

580+}

581+|]

582+

583+-- ========================================================================

584+-- ResourceId (series of newtypes)

585+-- ========================================================================

586+

587+newtype Id = Id String deriving (Generic)

588+instance ToSchema Id

589+

590+newtype ResourceId = ResourceId Id deriving (Generic)

591+instance ToSchema ResourceId

592+

593+-- ========================================================================

594+-- ButtonImages (bounded enum key mapping)

595+-- ========================================================================

596+

597+data ButtonState = Neutral | Focus | Active | Hover | Disabled

598+ deriving (Show, Bounded, Enum, Generic)

599+

600+instance ToJSON ButtonState

601+instance ToSchema ButtonState

602+instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)

603+

604+type ImageUrl = Text.Text

605+

606+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

607+ deriving (Generic)

608+

609+instance ToJSON ButtonImages where

610+ toJSON = toJSON . getButtonImages

611+

612+instance ToSchema ButtonImages where

613+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

614+ declareSchemaBoundedEnumKeyMapping

615+

616+buttonImagesSchemaJSON :: Value

617+buttonImagesSchemaJSON = [aesonQQ|

618+{

619+ "type": "object",

620+ "properties":

621+ {

622+ "Neutral": { "type": "string" },

623+ "Focus": { "type": "string" },

624+ "Active": { "type": "string" },

625+ "Hover": { "type": "string" },

626+ "Disabled": { "type": "string" }

627+ }

628+}

629+|]

630+

631+-- ========================================================================

632+-- SingleMaybeField (single field data with optional field)

633+-- ========================================================================

634+

635+data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }

636+ deriving (Show, Generic)

637+

638+instance ToJSON SingleMaybeField

639+instance ToSchema SingleMaybeField

640+

641+singleMaybeFieldSchemaJSON :: Value

642+singleMaybeFieldSchemaJSON = [aesonQQ|

643+{

644+ "type": "object",

645+ "properties":

646+ {

647+ "singleMaybeField": { "type": "string" }

648+ }

649+}

650+|]

651+

652+

653+-- ========================================================================

654+-- TimeOfDay

655+-- ========================================================================

656+data TimeOfDay

657+ = Int

658+ | Pico

659+ deriving (Generic)

660+instance ToSchema TimeOfDay

661+instance ToParamSchema TimeOfDay

662+

663+

664+timeOfDaySchemaJSON :: Value

665+timeOfDaySchemaJSON = [aesonQQ|

666+{

667+ "example": "12:33:15",

668+ "type": "string",

669+ "format": "hh:MM:ss"

670+}

671+|]

672+

673+timeOfDayParamSchemaJSON :: Value

674+timeOfDayParamSchemaJSON = [aesonQQ|

675+{

676+ "type": "string",

677+ "format": "hh:MM:ss"

678+}

679+|]

test/Data/Swagger/ParamSchemaSpec.hs+7−83

@@ -3,10 +3,11 @@

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE QuasiQuotes #-}

6+{-# LANGUAGE OverloadedStrings #-}

6module Data.Swagger.ParamSchemaSpec where

7module Data.Swagger.ParamSchemaSpec where

8import Data.Aeson

9import Data.Aeson

9−import Data.Aeson.QQ

10+import Data.Aeson.QQ.Simple

10import Data.Char

11import Data.Char

11import Data.Proxy

12import Data.Proxy

12import GHC.Generics

13import GHC.Generics

@@ -14,8 +15,12 @@ import GHC.Generics

14import Data.Swagger

15import Data.Swagger

15import Data.Swagger.Internal (SwaggerKind(..))

16import Data.Swagger.Internal (SwaggerKind(..))

18+import Data.Swagger.CommonTestTypes

17import SpecCommon

19import SpecCommon

18import Test.Hspec

20import Test.Hspec

21+import Data.Time.LocalTime

22+

23+import qualified Data.HashMap.Strict as HM

20checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

25checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

21checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

26checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

@@ -29,88 +34,7 @@ spec = do

29 context "Unary records" $ do

34 context "Unary records" $ do

30 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

35 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

31 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

36 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

33main :: IO ()

39main :: IO ()

34main = hspec spec

40main = hspec spec

35−

36−-- ========================================================================

37−-- Unit type

38−-- ========================================================================

39−

40−data Unit = Unit deriving (Generic)

41−instance ToParamSchema Unit

42−

43−unitSchemaJSON :: Value

44−unitSchemaJSON = [aesonQQ|

45−{

46− "type": "string",

47− "enum": ["Unit"]

48−}

49−|]

50−

51−-- ========================================================================

52−-- Color (enum)

53−-- ========================================================================

54−data Color

55− = Red

56− | Green

57− | Blue

58− deriving (Generic)

59−instance ToParamSchema Color

60−

61−colorSchemaJSON :: Value

62−colorSchemaJSON = [aesonQQ|

63−{

64− "type": "string",

65− "enum": ["Red", "Green", "Blue"]

66−}

67−|]

68−

69−-- ========================================================================

70−-- Status (constructorTagModifier)

71−-- ========================================================================

72−

73−data Status = StatusOk | StatusError deriving (Generic)

74−

75−instance ToParamSchema Status where

76− toParamSchema = genericToParamSchema defaultSchemaOptions

77− { constructorTagModifier = map toLower . drop (length "Status") }

78−

79−statusSchemaJSON :: Value

80−statusSchemaJSON = [aesonQQ|

81−{

82− "type": "string",

83− "enum": ["ok", "error"]

84−}

85−|]

86−

87−-- ========================================================================

88−-- Email (newtype with unwrapUnaryRecords set to True)

89−-- ========================================================================

90−

91−newtype Email = Email { getEmail :: String }

92− deriving (Generic)

93−instance ToParamSchema Email

94−

95−emailSchemaJSON :: Value

96−emailSchemaJSON = [aesonQQ|

97−{

98− "type": "string"

99−}

100−|]

101−

102−-- ========================================================================

103−-- UserId (non-record newtype)

104−-- ========================================================================

105−

106−newtype UserId = UserId Integer

107− deriving (Generic)

108−instance ToParamSchema UserId

109−

110−userIdSchemaJSON :: Value

111−userIdSchemaJSON = [aesonQQ|

112−{

113− "type": "integer"

114−}

115−|]

116−

test/Data/Swagger/Schema/GeneratorSpec.hsnew file+168

@@ -0,0 +1,168 @@

1+{-# LANGUAGE OverloadedLists #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE PackageImports #-}

4+module Data.Swagger.Schema.GeneratorSpec where

6+import Prelude ()

7+import Prelude.Compat

9+import Data.Swagger

10+import Data.Swagger.Schema.Generator

11+

12+import Control.Lens.Operators

13+import Data.Aeson

14+import Data.Hashable (Hashable)

15+import Data.HashMap.Strict (HashMap)

16+import qualified Data.HashMap.Strict as HashMap

17+import "unordered-containers" Data.HashSet (HashSet)

18+import qualified "unordered-containers" Data.HashSet as HashSet

19+import Data.Int

20+import Data.IntMap (IntMap)

21+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

22+import Data.Map (Map, fromList)

23+import Data.Monoid (mempty)

24+import Data.Proxy

25+import Data.Proxy

26+import Data.Set (Set)

27+import qualified Data.Text as T

28+import qualified Data.Text.Lazy as TL

29+import Data.Time

30+import Data.Version (Version)

31+import Data.Word

32+import GHC.Generics

33+

34+import Test.Hspec

35+import Test.Hspec.QuickCheck

36+import Test.QuickCheck

37+

38+shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

39+shouldValidate = validateFromJSON

40+

41+

42+shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

43+shouldNotValidate = expectFailure . shouldValidate

44+

45+

46+spec :: Spec

47+spec = do

48+ describe "FromJSON validation" $ do

49+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)

50+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)

51+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)

52+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)

53+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)

54+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)

55+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)

56+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)

57+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)

58+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)

59+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)

60+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)

61+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)

62+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)

63+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)

64+ prop "String" $ shouldValidate (Proxy :: Proxy String)

65+ prop "()" $ shouldValidate (Proxy :: Proxy ())

66+-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)

67+-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)

68+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)

69+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)

70+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])

71+ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

72+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

73+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

74+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

75+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

76+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

77+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

78+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))

79+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))

80+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))

81+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

82+ prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

83+ prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

84+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)

85+ prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

86+ prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

87+ prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

88+ describe "Invalid FromJSON validation" $ do

89+ prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)

90+ prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)

91+ prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)

92+ prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)

93+

94+-- =============================

95+-- Data types and bunk instances

96+-- =============================

97+

98+data WrongType = WrongType Bool

99+

100+instance FromJSON WrongType where

101+ parseJSON = withBool "WrongType" $ return . WrongType

102+

103+instance ToSchema WrongType where

104+ declareNamedSchema _ = return . NamedSchema (Just "WrongType") $

105+ mempty

106+ & type_ ?~ SwaggerObject

107+

108+

109+data MissingRequired = MissingRequired

110+ { propA :: String

111+ , propB :: Bool

112+ }

113+

114+instance FromJSON MissingRequired where

115+ parseJSON = withObject "MissingRequired" $ \o ->

116+ MissingRequired

117+ <$> o .: "propA"

118+ <*> o .: "propB"

119+

120+instance ToSchema MissingRequired where

121+ declareNamedSchema _ = do

122+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)

123+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

124+ return . NamedSchema (Just "MissingRequired") $

125+ mempty

126+ & type_ ?~ SwaggerObject

127+ & properties .~ [("propA", stringSchema)

128+ ,("propB", boolSchema)

129+ ]

130+ & required .~ ["propA"]

131+

132+data MissingProperty = MissingProperty

133+ { propC :: String

134+ , propD :: Bool

135+ }

136+

137+instance FromJSON MissingProperty where

138+ parseJSON = withObject "MissingProperty" $ \o ->

139+ MissingProperty

140+ <$> o .: "propC"

141+ <*> o .: "propD"

142+

143+instance ToSchema MissingProperty where

144+ declareNamedSchema _ = do

145+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)

146+ return . NamedSchema (Just "MissingProperty") $

147+ mempty

148+ & type_ ?~ SwaggerObject

149+ & properties .~ [("propC", stringSchema)]

150+ & required .~ ["propC"]

151+

152+data WrongPropType = WrongPropType

153+ { propE :: String

154+ }

155+

156+instance FromJSON WrongPropType where

157+ parseJSON = withObject "WrongPropType" $ \o ->

158+ WrongPropType

159+ <$> o .: "propE"

160+

161+instance ToSchema WrongPropType where

162+ declareNamedSchema _ = do

163+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

164+ return . NamedSchema (Just "WrongPropType") $

165+ mempty

166+ & type_ ?~ SwaggerObject

167+ & properties .~ [("propE", boolSchema)]

168+ & required .~ ["propE"]

test/Data/Swagger/Schema/ValidationSpec.hs+130−48

@@ -1,37 +1,50 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE PackageImports #-}

3+{-# LANGUAGE PackageImports #-}

4+{-# LANGUAGE RecordWildCards #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

4{-# OPTIONS_GHC -fno-warn-orphans #-}

6{-# OPTIONS_GHC -fno-warn-orphans #-}

5module Data.Swagger.Schema.ValidationSpec where

7module Data.Swagger.Schema.ValidationSpec where

7−import Control.Applicative

9+import Control.Applicative

10+import Control.Lens ((&), (.~), (?~))

8−import Data.Aeson

11+import Data.Aeson

9−import Data.Aeson.Types

12+import Data.Aeson.Types

10−import Data.Int

13+import Data.Hashable (Hashable)

11−import Data.IntMap (IntMap)

14+import Data.HashMap.Strict (HashMap)

12−import Data.Hashable (Hashable)

15+import qualified Data.HashMap.Strict as HashMap

13−import "unordered-containers" Data.HashSet (HashSet)

16+import "unordered-containers" Data.HashSet (HashSet)

14import qualified "unordered-containers" Data.HashSet as HashSet

17import qualified "unordered-containers" Data.HashSet as HashSet

15−import Data.HashMap.Strict (HashMap)

18+import Data.Int

16−import qualified Data.HashMap.Strict as HashMap

19+import Data.IntMap (IntMap)

20+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

17−import Data.Map (Map)

21+import Data.Map (Map, fromList)

22+import Data.Monoid (mempty)

18−import Data.Proxy

23+import Data.Proxy

19−import Data.Time

24+import Data.Set (Set)

20−import qualified Data.Text as T

25+import qualified Data.Text as T

21−import qualified Data.Text.Lazy as TL

26+import qualified Data.Text.Lazy as TL

22−import Data.Set (Set)

27+import Data.Time

28+import Data.Version (Version)

23−import Data.Word

29+import Data.Word

24−import GHC.Generics

30+import GHC.Generics

25−

31+

32+import Data.Swagger

26−import Data.Swagger

33+import Data.Swagger.Declare

27−

34+

28−import Test.Hspec

35+import Test.Hspec

29−import Test.Hspec.QuickCheck

36+import Test.Hspec.QuickCheck

30−import Test.QuickCheck

37+import Test.QuickCheck

38+import Test.QuickCheck.Instances ()

32shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

40shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

33shouldValidate _ x = validateToJSON x == []

41shouldValidate _ x = validateToJSON x == []

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+

35spec :: Spec

48spec :: Spec

36spec = do

49spec = do

37 describe "Validation" $ do

50 describe "Validation" $ do

@@ -60,6 +73,7 @@ spec = do

60 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

73 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

61 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

74 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

62 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

75 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

76+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

63 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

77 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

64 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

78 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

65 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

79 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

@@ -69,6 +83,7 @@ spec = do

69 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

83 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

70 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

84 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

71 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

85 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

86+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)

72 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

87 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

73 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

88 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

74 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

89 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

@@ -77,6 +92,16 @@ spec = do

77 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

92 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

78 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

93 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

79 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

94 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

95+ prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)

96+ prop "Version" $ shouldValidate (Proxy :: Proxy Version)

97+ prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)

98+

99+ describe "invalid cases" $ do

100+ prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON

101+ prop "invalidColorToJSON" $ shouldNotValidate invalidColorToJSON

102+ prop "invalidPaintToJSON" $ shouldNotValidate invalidPaintToJSON

103+ prop "invalidLightToJSON" $ shouldNotValidate invalidLightToJSON

104+ prop "invalidButtonImagesToJSON" $ shouldNotValidate invalidButtonImagesToJSON

105

81main :: IO ()

106main :: IO ()

82main = hspec spec

107main = hspec spec

@@ -96,6 +121,13 @@ instance ToSchema Person

96instance Arbitrary Person where

121instance Arbitrary Person where

97 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

122 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

123

124+invalidPersonToJSON :: Person -> Value

125+invalidPersonToJSON Person{..} = object

126+ [ T.pack "personName" .= toJSON name

127+ , T.pack "personPhone" .= toJSON phone

128+ , T.pack "personEmail" .= toJSON email

129+ ]

130+

99-- ========================================================================

131-- ========================================================================

100-- Color (enum)

132-- Color (enum)

101-- ========================================================================

133-- ========================================================================

@@ -107,6 +139,11 @@ instance ToSchema Color

107instance Arbitrary Color where

139instance Arbitrary Color where

108 arbitrary = arbitraryBoundedEnum

140 arbitrary = arbitraryBoundedEnum

109

141

142+invalidColorToJSON :: Color -> Value

143+invalidColorToJSON Red = toJSON "red"

144+invalidColorToJSON Green = toJSON "green"

145+invalidColorToJSON Blue = toJSON "blue"

146+

110-- ========================================================================

147-- ========================================================================

111-- Paint (record with bounded enum property)

148-- Paint (record with bounded enum property)

112-- ========================================================================

149-- ========================================================================

@@ -120,6 +157,9 @@ instance ToSchema Paint

120instance Arbitrary Paint where

157instance Arbitrary Paint where

121 arbitrary = Paint <$> arbitrary

158 arbitrary = Paint <$> arbitrary

122

159

160+invalidPaintToJSON :: Paint -> Value

161+invalidPaintToJSON = toJSON . color

162+

123-- ========================================================================

163-- ========================================================================

124-- MyRoseTree (custom datatypeNameModifier)

164-- MyRoseTree (custom datatypeNameModifier)

125-- ========================================================================

165-- ========================================================================

@@ -161,36 +201,78 @@ instance Arbitrary Light where

161 , LightColor <$> arbitrary

201 , LightColor <$> arbitrary

162 ]

202 ]

163

203

164−-- Arbitrary instances for common types

204+invalidLightToJSON :: Light -> Value

205+invalidLightToJSON = genericToJSON defaultOptions

165

206

166−instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

207+-- ========================================================================

167− arbitrary = HashMap.fromList <$> arbitrary

208+-- ButtonImages (bounded enum key mapping)

209+-- ========================================================================

168

210

169−instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where

211+data ButtonState = Neutral | Focus | Active | Hover | Disabled

170− arbitrary = HashSet.fromList <$> arbitrary

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

222+

223+newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

224+ deriving (Show, Generic)

171

225

172−instance Arbitrary T.Text where

226+instance ToJSON ButtonImages where

173− arbitrary = T.pack <$> arbitrary

227+ toJSON = toJSON . getButtonImages

174

228

175−instance Arbitrary TL.Text where

229+instance ToSchema ButtonImages where

176− arbitrary = TL.pack <$> arbitrary

230+ declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

231+ declareSchemaBoundedEnumKeyMapping

177

232

178−instance Arbitrary Day where

233+invalidButtonImagesToJSON :: ButtonImages -> Value

179− arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary

234+invalidButtonImagesToJSON = genericToJSON defaultOptions

180

235

181−instance Arbitrary LocalTime where

236+instance Arbitrary ButtonImages where

182− arbitrary = LocalTime

183− <$> arbitrary

237+ arbitrary = ButtonImages <$> arbitrary

184− <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))

238+

239+-- ========================================================================

240+-- FreeForm (wraps a raw JSON Value)

241+-- ========================================================================

242+

243+data FreeForm = FreeForm { jsonContent :: Map T.Text Value }

244+ deriving (Show, Generic)

245+

246+instance ToJSON FreeForm where

247+ toJSON = toJSON . jsonContent

248+

249+instance ToSchema FreeForm where

250+ declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty

251+ & type_ ?~ SwaggerObject

252+ & additionalProperties ?~ AdditionalPropertiesAllowed True

253+

254+instance Arbitrary FreeForm where

255+ arbitrary = (FreeForm . fromList) <$> genObj

256+ where

257+ genObj = listOf $ do

258+ k <- arbitrary

259+ v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]

260+ pure (k, v)

185

261

186instance Eq ZonedTime where

262instance Eq ZonedTime where

187 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

263 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

188

264

189−instance Arbitrary ZonedTime where

265+-- ========================================================================

190− arbitrary = ZonedTime

266+-- Arbitrary instance for Data.Aeson.Value

191− <$> arbitrary

267+-- ========================================================================

192− <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))

193−

194−instance Arbitrary UTCTime where

195− arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))

196

268

269+instance Arbitrary Value where

270+ -- Weights are almost random

271+ -- Uniform oneof tends not to build complex objects cause of recursive call.

272+ arbitrary = resize 4 $ frequency

273+ [ (3, Object <$> arbitrary)

274+ , (3, Array <$> arbitrary)

275+ , (3, String <$> arbitrary)

276+ , (3, Number <$> arbitrary)

277+ , (3, Bool <$> arbitrary)

278+ , (1, return Null) ]

test/Data/Swagger/SchemaSpec.hs+12−547

@@ -8,21 +8,22 @@ import Prelude ()

8import Prelude.Compat

10import Control.Lens ((^.))

11−import Data.Aeson

11+import Data.Aeson (Value)

12−import Data.Aeson.QQ

13−import Data.Char

14import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

12import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

15import Data.Proxy

13import Data.Proxy

16import Data.Set (Set)

14import Data.Set (Set)

17import qualified Data.Text as Text

15import qualified Data.Text as Text

18−import GHC.Generics

20import Data.Swagger

17import Data.Swagger

21import Data.Swagger.Declare

18import Data.Swagger.Declare

20+import Data.Swagger.CommonTestTypes

23import SpecCommon

21import SpecCommon

24import Test.Hspec

22import Test.Hspec

24+import qualified Data.HashMap.Strict as HM

25+import Data.Time.LocalTime

26+

26checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

27checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

27checkToSchema proxy js = toSchema proxy <=> js

28checkToSchema proxy js = toSchema proxy <=> js

@@ -76,8 +77,10 @@ spec = do

76 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON

77 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON

77 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON

78 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON

78 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON

79 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON

80+ context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON

79 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON

81 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON

80 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

82 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

83+ context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

81 context "Sum types" $ do

84 context "Sum types" $ do

82 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON

85 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON

83 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON

86 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON

@@ -93,6 +96,7 @@ spec = do

93 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]

96 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]

94 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

97 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

95 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

98 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

99+ context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]

96 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

100 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

97 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []

101 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []

98 describe "Inlining Schemas" $ do

102 describe "Inlining Schemas" $ do

@@ -101,549 +105,10 @@ spec = do

101 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

105 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

102 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

106 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

103 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

107 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

108+ context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

109+ describe "Bounded Enum key mapping" $ do

110+ context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

111+ context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON

104

112

105main :: IO ()

113main :: IO ()

106main = hspec spec

114main = hspec spec

107−

108−-- ========================================================================

109−-- Person (simple record with optional fields)

110−-- ========================================================================

111−data Person = Person

112− { name :: String

113− , phone :: Integer

114− , email :: Maybe String

115− } deriving (Generic)

116−

117−instance ToSchema Person

118−

119−personSchemaJSON :: Value

120−personSchemaJSON = [aesonQQ|

121−{

122− "type": "object",

123− "properties":

124− {

125− "name": { "type": "string" },

126− "phone": { "type": "integer" },

127− "email": { "type": "string" }

128− },

129− "required": ["name", "phone"]

130−}

131−|]

132−

133−-- ========================================================================

134−-- ISPair (non-record product data type)

135−-- ========================================================================

136−data ISPair = ISPair Integer String

137− deriving (Generic)

138−

139−instance ToSchema ISPair

140−

141−ispairSchemaJSON :: Value

142−ispairSchemaJSON = [aesonQQ|

143−{

144− "type": "array",

145− "items":

146− [

147− { "type": "integer" },

148− { "type": "string" }

149− ],

150− "minItems": 2,

151− "maxItems": 2

152−}

153−|]

154−

155−-- ========================================================================

156−-- Point (record data type with custom fieldLabelModifier)

157−-- ========================================================================

158−

159−data Point = Point

160− { pointX :: Double

161− , pointY :: Double

162− } deriving (Generic)

163−

164−instance ToSchema Point where

165− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

166− { fieldLabelModifier = map toLower . drop (length "point") }

167−

168−pointSchemaJSON :: Value

169−pointSchemaJSON = [aesonQQ|

170−{

171− "type": "object",

172− "properties":

173− {

174− "x": { "type": "number", "format": "double" },

175− "y": { "type": "number", "format": "double" }

176− },

177− "required": ["x", "y"]

178−}

179−|]

180−

181−-- ========================================================================

182−-- Point (record data type with multiple fields)

183−-- ========================================================================

184−

185−data Point5 = Point5

186− { point5X :: Double

187− , point5Y :: Double

188− , point5Z :: Double

189− , point5U :: Double

190− , point5V :: Double -- 5 dimensional!

191− } deriving (Generic)

192−

193−instance ToSchema Point5 where

194− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

195− { fieldLabelModifier = map toLower . drop (length "point5") }

196−

197−point5SchemaJSON :: Value

198−point5SchemaJSON = [aesonQQ|

199−{

200− "type": "object",

201− "properties":

202− {

203− "x": { "type": "number", "format": "double" },

204− "y": { "type": "number", "format": "double" },

205− "z": { "type": "number", "format": "double" },

206− "u": { "type": "number", "format": "double" },

207− "v": { "type": "number", "format": "double" }

208− },

209− "required": ["x", "y", "z", "u", "v"]

210−}

211−|]

212−

213−point5Properties :: [String]

214−point5Properties = ["x", "y", "z", "u", "v"]

215−

216−-- ========================================================================

217−-- Color (enum)

218−-- ========================================================================

219−data Color

220− = Red

221− | Green

222− | Blue

223− deriving (Generic)

224−instance ToSchema Color

225−

226−colorSchemaJSON :: Value

227−colorSchemaJSON = [aesonQQ|

228−{

229− "type": "string",

230− "enum": ["Red", "Green", "Blue"]

231−}

232−|]

233−

234−-- ========================================================================

235−-- Shade (paramSchemaToNamedSchema)

236−-- ========================================================================

237−

238−data Shade = Dim | Bright deriving (Generic)

239−instance ToParamSchema Shade

240−

241−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions

242−

243−shadeSchemaJSON :: Value

244−shadeSchemaJSON = [aesonQQ|

245−{

246− "type": "string",

247− "enum": ["Dim", "Bright"]

248−}

249−|]

250−

251−-- ========================================================================

252−-- Paint (record with bounded enum property)

253−-- ========================================================================

254−

255−newtype Paint = Paint { color :: Color }

256− deriving (Generic)

257−instance ToSchema Paint

258−

259−paintSchemaJSON :: Value

260−paintSchemaJSON = [aesonQQ|

261−{

262− "type": "object",

263− "properties":

264− {

265− "color":

266− {

267− "$ref": "#/definitions/Color"

268− }

269− },

270− "required": ["color"]

271−}

272−|]

273−

274−paintInlinedSchemaJSON :: Value

275−paintInlinedSchemaJSON = [aesonQQ|

276−{

277− "type": "object",

278− "properties":

279− {

280− "color":

281− {

282− "type": "string",

283− "enum": ["Red", "Green", "Blue"]

284− }

285− },

286− "required": ["color"]

287−}

288−|]

289−

290−-- ========================================================================

291−-- Email (newtype with unwrapUnaryRecords set to True)

292−-- ========================================================================

293−

294−newtype Email = Email { getEmail :: String }

295− deriving (Generic)

296−

297−instance ToSchema Email where

298− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

299− { unwrapUnaryRecords = True }

300−

301−emailSchemaJSON :: Value

302−emailSchemaJSON = [aesonQQ|

303−{

304− "type": "string"

305−}

306−|]

307−

308−-- ========================================================================

309−-- UserId (non-record newtype)

310−-- ========================================================================

311−

312−newtype UserId = UserId Integer

313− deriving (Eq, Ord, Generic)

314−instance ToSchema UserId

315−

316−userIdSchemaJSON :: Value

317−userIdSchemaJSON = [aesonQQ|

318−{

319− "type": "integer"

320−}

321−|]

322−

323−-- ========================================================================

324−-- UserGroup (set newtype)

325−-- ========================================================================

326−

327−newtype UserGroup = UserGroup (Set UserId)

328− deriving (Generic)

329−instance ToSchema UserGroup

330−

331−userGroupSchemaJSON :: Value

332−userGroupSchemaJSON = [aesonQQ|

333−{

334− "type": "array",

335− "items": { "$ref": "#/definitions/UserId" },

336− "uniqueItems": true

337−}

338−|]

339−

340−-- ========================================================================

341−-- Player (record newtype)

342−-- ========================================================================

343−

344−newtype Player = Player

345− { position :: Point

346− } deriving (Generic)

347−instance ToSchema Player

348−

349−playerSchemaJSON :: Value

350−playerSchemaJSON = [aesonQQ|

351−{

352− "type": "object",

353− "properties":

354− {

355− "position":

356− {

357− "$ref": "#/definitions/Point"

358− }

359− },

360− "required": ["position"]

361−}

362−|]

363−

364−-- ========================================================================

365−-- MyRoseTree (custom datatypeNameModifier)

366−-- ========================================================================

367−

368−data MyRoseTree = MyRoseTree

369− { root :: String

370− , trees :: [MyRoseTree]

371− } deriving (Generic)

372−

373−instance ToSchema MyRoseTree where

374− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

375− { datatypeNameModifier = drop (length "My") }

376−

377−myRoseTreeSchemaJSON :: Value

378−myRoseTreeSchemaJSON = [aesonQQ|

379−{

380− "type": "object",

381− "properties":

382− {

383− "root": { "type": "string" },

384− "trees":

385− {

386− "type": "array",

387− "items":

388− {

389− "$ref": "#/definitions/RoseTree"

390− }

391− }

392− },

393− "required": ["root", "trees"]

394−}

395−|]

396−

397−-- ========================================================================

398−-- Inlined (newtype for inlining schemas)

399−-- ========================================================================

400−

401−newtype Inlined a = Inlined { getInlined :: a }

402−

403−instance ToSchema a => ToSchema (Inlined a) where

404− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

405− where

406− unname (NamedSchema _ s) = NamedSchema Nothing s

407−

408−newtype Players = Players [Inlined Player]

409− deriving (Generic)

410−instance ToSchema Players

411−

412−playersSchemaJSON :: Value

413−playersSchemaJSON = [aesonQQ|

414−{

415− "type": "array",

416− "items":

417− {

418− "type": "object",

419− "properties":

420− {

421− "position":

422− {

423− "$ref": "#/definitions/Point"

424− }

425− },

426− "required": ["position"]

427− }

428−}

429−|]

430−

431−-- ========================================================================

432−-- Status (sum type with unary constructors)

433−-- ========================================================================

434−

435−data Status

436− = StatusOk String

437− | StatusError String

438− deriving (Generic)

439−

440−instance ToSchema Status where

441− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

442− { constructorTagModifier = map toLower . drop (length "Status") }

443−

444−statusSchemaJSON :: Value

445−statusSchemaJSON = [aesonQQ|

446−{

447− "type": "object",

448− "properties":

449− {

450− "ok": { "type": "string" },

451− "error": { "type": "string" }

452− },

453− "maxProperties": 1,

454− "minProperties": 1

455−}

456−|]

457−

458−-- ========================================================================

459−-- Unit type

460−-- ========================================================================

461−

462−data Unit = Unit deriving (Generic)

463−instance ToSchema Unit

464−

465−unitSchemaJSON :: Value

466−unitSchemaJSON = [aesonQQ|

467−{

468− "type": "string",

469− "enum": ["Unit"]

470−}

471−|]

472−

473−

474−-- ========================================================================

475−-- Character (sum type with ref and record in alternative)

476−-- ========================================================================

477−

478−data Character

479− = PC Player

480− | NPC { npcName :: String, npcPosition :: Point }

481− deriving (Generic)

482−instance ToSchema Character

483−

484−characterSchemaJSON :: Value

485−characterSchemaJSON = [aesonQQ|

486−{

487− "type": "object",

488− "properties":

489− {

490− "PC": { "$ref": "#/definitions/Player" },

491− "NPC":

492− {

493− "type": "object",

494− "properties":

495− {

496− "npcName": { "type": "string" },

497− "npcPosition": { "$ref": "#/definitions/Point" }

498− },

499− "required": ["npcName", "npcPosition"]

500− }

501− },

502− "maxProperties": 1,

503− "minProperties": 1

504−}

505−|]

506−

507−characterInlinedSchemaJSON :: Value

508−characterInlinedSchemaJSON = [aesonQQ|

509−{

510− "type": "object",

511− "properties":

512− {

513− "PC":

514− {

515− "type": "object",

516− "properties":

517− {

518− "position":

519− {

520− "type": "object",

521− "properties":

522− {

523− "x": { "type": "number", "format": "double" },

524− "y": { "type": "number", "format": "double" }

525− },

526− "required": ["x", "y"]

527− }

528− },

529− "required": ["position"]

530− },

531− "NPC":

532− {

533− "type": "object",

534− "properties":

535− {

536− "npcName": { "type": "string" },

537− "npcPosition":

538− {

539− "type": "object",

540− "properties":

541− {

542− "x": { "type": "number", "format": "double" },

543− "y": { "type": "number", "format": "double" }

544− },

545− "required": ["x", "y"]

546− }

547− },

548− "required": ["npcName", "npcPosition"]

549− }

550− },

551− "maxProperties": 1,

552− "minProperties": 1

553−}

554−|]

555−

556−characterInlinedPlayerSchemaJSON :: Value

557−characterInlinedPlayerSchemaJSON = [aesonQQ|

558−{

559− "type": "object",

560− "properties":

561− {

562− "PC":

563− {

564− "type": "object",

565− "properties":

566− {

567− "position":

568− {

569− "$ref": "#/definitions/Point"

570− }

571− },

572− "required": ["position"]

573− },

574− "NPC":

575− {

576− "type": "object",

577− "properties":

578− {

579− "npcName": { "type": "string" },

580− "npcPosition": { "$ref": "#/definitions/Point" }

581− },

582− "required": ["npcName", "npcPosition"]

583− }

584− },

585− "maxProperties": 1,

586− "minProperties": 1

587−}

588−|]

589−

590−-- ========================================================================

591−-- Light (sum type with unwrapUnaryRecords)

592−-- ========================================================================

593−

594−data Light

595− = NoLight

596− | LightFreq Double

597− | LightColor Color

598− | LightWaveLength { waveLength :: Double }

599− deriving (Generic)

600−

601−instance ToSchema Light where

602− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

603− { unwrapUnaryRecords = True }

604−

605−lightSchemaJSON :: Value

606−lightSchemaJSON = [aesonQQ|

607−{

608− "type": "object",

609− "properties":

610− {

611− "NoLight": { "type": "array", "items": [] },

612− "LightFreq": { "type": "number", "format": "double" },

613− "LightColor": { "$ref": "#/definitions/Color" },

614− "LightWaveLength": { "type": "number", "format": "double" }

615− },

616− "maxProperties": 1,

617− "minProperties": 1

618−}

619−|]

620−

621−lightInlinedSchemaJSON :: Value

622−lightInlinedSchemaJSON = [aesonQQ|

623−{

624− "type": "object",

625− "properties":

626− {

627− "NoLight": { "type": "array", "items": [] },

628− "LightFreq": { "type": "number", "format": "double" },

629− "LightColor":

630− {

631− "type": "string",

632− "enum": ["Red", "Green", "Blue"]

633− },

634− "LightWaveLength": { "type": "number", "format": "double" }

635− },

636− "maxProperties": 1,

637− "minProperties": 1

638−}

639−|]

640−

641−-- ========================================================================

642−-- ResourceId (series of newtypes)

643−-- ========================================================================

644−

645−newtype Id = Id String deriving (Generic)

646−instance ToSchema Id

647−

648−newtype ResourceId = ResourceId Id deriving (Generic)

649−instance ToSchema ResourceId

test/Data/SwaggerSpec.hs+114−28

@@ -10,9 +10,9 @@ import Prelude.Compat

10import Control.Lens

12import Data.Aeson

13−import Data.Aeson.QQ

13+import Data.Aeson.QQ.Simple

14import Data.HashMap.Strict (HashMap)

15−import qualified Data.Set as Set

15+import qualified Data.HashSet.InsOrd as InsOrdHS

16import Data.Text (Text)

18import Data.Swagger

@@ -37,11 +37,14 @@ spec = do

37 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON

38 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON

39 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON

40+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON

40 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

41 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

41 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

42 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

42 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

43 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

43 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

44 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

44 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

45 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

47+ describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

45 describe "Swagger Object" $ do

48 describe "Swagger Object" $ do

46 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

49 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

47 context "PetStore Example" $

50 context "PetStore Example" $

@@ -125,7 +128,7 @@ licenseExampleJSON = [aesonQQ|

125

128

126operationExample :: Operation

129operationExample :: Operation

127operationExample = mempty

130operationExample = mempty

128− & tags .~ Set.fromList ["pet"]

131+ & tags .~ InsOrdHS.fromList ["pet"]

129 & summary ?~ "Updates a pet in the store with form data"

132 & summary ?~ "Updates a pet in the store with form data"

130 & description ?~ ""

133 & description ?~ ""

131 & operationId ?~ "updatePetWithForm"

134 & operationId ?~ "updatePetWithForm"

@@ -156,7 +159,7 @@ operationExample = mempty

156 stringSchema :: ParamLocation -> ParamOtherSchema

159 stringSchema :: ParamLocation -> ParamOtherSchema

157 stringSchema loc = mempty

160 stringSchema loc = mempty

158 & in_ .~ loc

161 & in_ .~ loc

159− & type_ .~ SwaggerString

162+ & type_ ?~ SwaggerString

160

163

161operationExampleJSON :: Value

164operationExampleJSON :: Value

162operationExampleJSON = [aesonQQ|

165operationExampleJSON = [aesonQQ|

@@ -222,7 +225,7 @@ operationExampleJSON = [aesonQQ|

222

225

223schemaPrimitiveExample :: Schema

226schemaPrimitiveExample :: Schema

224schemaPrimitiveExample = mempty

227schemaPrimitiveExample = mempty

225− & type_ .~ SwaggerString

228+ & type_ ?~ SwaggerString

226 & format ?~ "email"

229 & format ?~ "email"

227

230

228schemaPrimitiveExampleJSON :: Value

231schemaPrimitiveExampleJSON :: Value

@@ -235,14 +238,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

235

238

236schemaSimpleModelExample :: Schema

239schemaSimpleModelExample :: Schema

237schemaSimpleModelExample = mempty

240schemaSimpleModelExample = mempty

238− & type_ .~ SwaggerObject

241+ & type_ ?~ SwaggerObject

239 & required .~ [ "name" ]

242 & required .~ [ "name" ]

240 & properties .~

243 & properties .~

241− [ ("name", Inline (mempty & type_ .~ SwaggerString))

244+ [ ("name", Inline (mempty & type_ ?~ SwaggerString))

242 , ("address", Ref (Reference "Address"))

245 , ("address", Ref (Reference "Address"))

243 , ("age", Inline $ mempty

246 , ("age", Inline $ mempty

244 & minimum_ ?~ 0

247 & minimum_ ?~ 0

245− & type_ .~ SwaggerInteger

248+ & type_ ?~ SwaggerInteger

246 & format ?~ "int32" ) ]

249 & format ?~ "int32" ) ]

247

250

248schemaSimpleModelExampleJSON :: Value

251schemaSimpleModelExampleJSON :: Value

@@ -270,8 +273,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

270

273

271schemaModelDictExample :: Schema

274schemaModelDictExample :: Schema

272schemaModelDictExample = mempty

275schemaModelDictExample = mempty

273− & type_ .~ SwaggerObject

276+ & type_ ?~ SwaggerObject

274− & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)

277+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

275

278

276schemaModelDictExampleJSON :: Value

279schemaModelDictExampleJSON :: Value

277schemaModelDictExampleJSON = [aesonQQ|

280schemaModelDictExampleJSON = [aesonQQ|

@@ -283,15 +286,28 @@ schemaModelDictExampleJSON = [aesonQQ|

283}

286}

284|]

287|]

285

288

289+schemaAdditionalExample :: Schema

290+schemaAdditionalExample = mempty

291+ & type_ ?~ SwaggerObject

292+ & additionalProperties ?~ AdditionalPropertiesAllowed True

293+

294+schemaAdditionalExampleJSON :: Value

295+schemaAdditionalExampleJSON = [aesonQQ|

296+{

297+ "type": "object",

298+ "additionalProperties": true

299+}

300+|]

301+

286schemaWithExampleExample :: Schema

302schemaWithExampleExample :: Schema

287schemaWithExampleExample = mempty

303schemaWithExampleExample = mempty

288− & type_ .~ SwaggerObject

304+ & type_ ?~ SwaggerObject

289 & properties .~

305 & properties .~

290 [ ("id", Inline $ mempty

306 [ ("id", Inline $ mempty

291− & type_ .~ SwaggerInteger

307+ & type_ ?~ SwaggerInteger

292 & format ?~ "int64" )

308 & format ?~ "int64" )

293 , ("name", Inline $ mempty

309 , ("name", Inline $ mempty

294− & type_ .~ SwaggerString) ]

310+ & type_ ?~ SwaggerString) ]

295 & required .~ [ "name" ]

311 & required .~ [ "name" ]

296 & example ?~ [aesonQQ|

312 & example ?~ [aesonQQ|

297 {

313 {

@@ -330,19 +346,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

330definitionsExample :: HashMap Text Schema

346definitionsExample :: HashMap Text Schema

331definitionsExample =

347definitionsExample =

332 [ ("Category", mempty

348 [ ("Category", mempty

333− & type_ .~ SwaggerObject

349+ & type_ ?~ SwaggerObject

334 & properties .~

350 & properties .~

335 [ ("id", Inline $ mempty

351 [ ("id", Inline $ mempty

336− & type_ .~ SwaggerInteger

352+ & type_ ?~ SwaggerInteger

337 & format ?~ "int64")

353 & format ?~ "int64")

338− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

354+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

339 , ("Tag", mempty

355 , ("Tag", mempty

340− & type_ .~ SwaggerObject

356+ & type_ ?~ SwaggerObject

341 & properties .~

357 & properties .~

342 [ ("id", Inline $ mempty

358 [ ("id", Inline $ mempty

343− & type_ .~ SwaggerInteger

359+ & type_ ?~ SwaggerInteger

344 & format ?~ "int64")

360 & format ?~ "int64")

345− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

361+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

346

362

347definitionsExampleJSON :: Value

363definitionsExampleJSON :: Value

348definitionsExampleJSON = [aesonQQ|

364definitionsExampleJSON = [aesonQQ|

@@ -386,7 +402,7 @@ paramsDefinitionExample =

386 & required ?~ True

402 & required ?~ True

387 & schema .~ ParamOther (mempty

403 & schema .~ ParamOther (mempty

388 & in_ .~ ParamQuery

404 & in_ .~ ParamQuery

389− & type_ .~ SwaggerInteger

405+ & type_ ?~ SwaggerInteger

390 & format ?~ "int32" ))

406 & format ?~ "int32" ))

391 , ("limitParam", mempty

407 , ("limitParam", mempty

392 & name .~ "limit"

408 & name .~ "limit"

@@ -394,7 +410,7 @@ paramsDefinitionExample =

394 & required ?~ True

410 & required ?~ True

395 & schema .~ ParamOther (mempty

411 & schema .~ ParamOther (mempty

396 & in_ .~ ParamQuery

412 & in_ .~ ParamQuery

397− & type_ .~ SwaggerInteger

413+ & type_ ?~ SwaggerInteger

398 & format ?~ "int32" )) ]

414 & format ?~ "int32" )) ]

399

415

400paramsDefinitionExampleJSON :: Value

416paramsDefinitionExampleJSON :: Value

@@ -444,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

444-- Responses Definition object

460-- Responses Definition object

445-- =======================================================================

461-- =======================================================================

446

462

447−securityDefinitionsExample :: HashMap Text SecurityScheme

463+securityDefinitionsExample :: SecurityDefinitions

448−securityDefinitionsExample =

464+securityDefinitionsExample = SecurityDefinitions

449 [ ("api_key", SecurityScheme

465 [ ("api_key", SecurityScheme

450 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

451 , _securitySchemeDescription = Nothing })

467 , _securitySchemeDescription = Nothing })

@@ -477,6 +493,46 @@ securityDefinitionsExampleJSON = [aesonQQ|

477}

493}

478|]

494|]

479

495

496+oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions

497+oAuth2SecurityDefinitionsReadExample = SecurityDefinitions

498+ [ ("petstore_auth", SecurityScheme

499+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params

500+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"

501+ , _oauth2Scopes =

502+ [ ("read:pets", "read your pets") ] } )

503+ , _securitySchemeDescription = Nothing })

504+ ]

505+

506+oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions

507+oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions

508+ [ ("petstore_auth", SecurityScheme

509+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params

510+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"

511+ , _oauth2Scopes =

512+ [ ("write:pets", "modify pets in your account") ] } )

513+ , _securitySchemeDescription = Nothing })

514+ ]

515+

516+oAuth2SecurityDefinitionsExample :: SecurityDefinitions

517+oAuth2SecurityDefinitionsExample =

518+ oAuth2SecurityDefinitionsWriteExample <>

519+ oAuth2SecurityDefinitionsReadExample

520+

521+oAuth2SecurityDefinitionsExampleJSON :: Value

522+oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|

523+{

524+ "petstore_auth": {

525+ "type": "oauth2",

526+ "authorizationUrl": "http://swagger.io/api/oauth/dialog",

527+ "flow": "implicit",

528+ "scopes": {

529+ "write:pets": "modify pets in your account",

530+ "read:pets": "read your pets"

531+ }

532+ }

533+}

534+|]

535+

480-- =======================================================================

536-- =======================================================================

481-- Swagger object

537-- Swagger object

482-- =======================================================================

538-- =======================================================================

@@ -495,7 +551,7 @@ swaggerExample = mempty

495 & at 200 ?~ Inline (mempty

551 & at 200 ?~ Inline (mempty

496 & description .~ "OK"

552 & description .~ "OK"

497 & schema ?~ Inline (mempty

553 & schema ?~ Inline (mempty

498− & type_ .~ SwaggerObject

554+ & type_ ?~ SwaggerObject

499 & example ?~ [aesonQQ|

555 & example ?~ [aesonQQ|

500 {

556 {

501 "created": 100,

557 "created": 100,

@@ -504,9 +560,9 @@ swaggerExample = mempty

504 & description ?~ "This is some real Todo right here"

560 & description ?~ "This is some real Todo right here"

505 & properties .~

561 & properties .~

506 [ ("created", Inline $ mempty

562 [ ("created", Inline $ mempty

507− & type_ .~ SwaggerInteger

563+ & type_ ?~ SwaggerInteger

508 & format ?~ "int32")

564 & format ?~ "int32")

509− , ("description", Inline (mempty & type_ .~ SwaggerString))]))

565+ , ("description", Inline (mempty & type_ ?~ SwaggerString))]))

510 & produces ?~ MimeList [ "application/json" ]

566 & produces ?~ MimeList [ "application/json" ]

511 & parameters .~

567 & parameters .~

512 [ Inline $ mempty

568 [ Inline $ mempty

@@ -515,8 +571,8 @@ swaggerExample = mempty

515 & description ?~ "TodoId param"

571 & description ?~ "TodoId param"

516 & schema .~ ParamOther (mempty

572 & schema .~ ParamOther (mempty

517 & in_ .~ ParamPath

573 & in_ .~ ParamPath

518− & type_ .~ SwaggerString ) ]

574+ & type_ ?~ SwaggerString ) ]

519− & tags .~ Set.fromList [ "todo" ] ))

575+ & tags .~ InsOrdHS.fromList [ "todo" ] ))

520

576

521swaggerExampleJSON :: Value

577swaggerExampleJSON :: Value

522swaggerExampleJSON = [aesonQQ|

578swaggerExampleJSON = [aesonQQ|

@@ -1614,3 +1670,33 @@ petstoreExampleJSON = [aesonQQ|

1614 }

1670 }

1615}

1671}

1616|]

1672|]

1673+

1674+compositionSchemaExample :: Schema

1675+compositionSchemaExample = mempty

1676+ & type_ ?~ SwaggerObject

1677+ & Data.Swagger.allOf ?~ [

1678+ Ref (Reference "Other")

1679+ , Inline (mempty

1680+ & type_ ?~ SwaggerObject

1681+ & properties .~

1682+ [ ("greet", Inline $ mempty

1683+ & type_ ?~ SwaggerString) ])

1684+ ]

1685+

1686+compositionSchemaExampleJSON :: Value

1687+compositionSchemaExampleJSON = [aesonQQ|

1688+{

1689+ "type": "object",

1690+ "allOf": [

1691+ {

1692+ "$ref": "#/definitions/Other"

1693+ },

1694+ {

1695+ "type": "object",

1696+ "properties": {

1697+ "greet": { "type": "string" }

1698+ }

1699+ }

1700+ ]

1701+}

1702+|]