master..15541f1 · typeable/swagger2

git.iko.soy/typeable/swagger2

.ghci+1−2

@@ -1,2 +1 @@

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

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

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

.gitignore−2

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

1dist

2−dist-newstyle

3−.ghc.environment.*

4cabal-dev

2cabal-dev

5*.o

3*.o

6*.hi

4*.hi

.travis.yml+67−150

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

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

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

2−#

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

4−#

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

6−#

7−# version: 0.5.20191020

8−#

9language: c

2language: c

10−dist: xenial

11−git:

12− # whether to recursively clone submodules

13− submodules: false

3+sudo: false

14−branches:

15− only:

16− - master

17cache:

5cache:

18 directories:

6 directories:

7+ - $HOME/.cabsnap

19 - $HOME/.cabal/packages

8 - $HOME/.cabal/packages

20− - $HOME/.cabal/store

21before_cache:

10before_cache:

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

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

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

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

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

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

13+

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

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

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

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

30matrix:

14matrix:

31 include:

15 include:

32− - compiler: ghc-8.8.1

16+ - env: CABALVER=1.18 GHCVER=7.8.4

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

17+ compiler: ": #GHC 7.8.4"

34− - compiler: ghc-8.6.5

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

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

36− - compiler: ghc-8.4.4

19+ - env: CABALVER=1.22 GHCVER=7.10.3

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

20+ compiler: ": #GHC 7.10.3"

38− - compiler: ghc-8.2.2

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

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

22+

40− - compiler: ghc-8.0.2

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

42before_install:

23before_install:

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

44− - WITHCOMPILER="-w $HC"

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

46− - HCPKG="$HC-pkg"

47− - unset CC

24+ - unset CC

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

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

49− - CABALHOME=$HOME/.cabal

26+

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

74install:

27install:

75− - ${CABAL} --version

28+ - cabal --version

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

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

77− - TEST=--enable-tests

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

78− - BENCH=--enable-benchmarks

31+ then

79− - HEADHACKAGE=false

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

80− - rm -f $CABALHOME/config

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

81− - |

34+ fi

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

105− - |

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

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

108− - cat $CABALHOME/config

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

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

35+ - travis_retry cabal update -v

111− # Generate cabal.project

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

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

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

113− - touch cabal.project

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

114− - |

39+

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

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

116− - |

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

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"

42+ then

118− - cat cabal.project || true

43+ echo "cabal build-cache HIT";

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

44+ rm -rfv .ghc;

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

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

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

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

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

47+ else

123− - rm cabal.project.freeze

48+ echo "cabal build-cache MISS";

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

49+ rm -rf $HOME/.cabsnap;

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

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

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

52+ fi

53+

54+# snapshot package-db on cache miss

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

56+ then

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

58+ mkdir $HOME/.cabsnap;

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

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

61+ fi

62+

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

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

126script:

65script:

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

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

128− # Packaging...

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

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

130− # Unpacking...

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

132− - cd ${DISTDIR} || false

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

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

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

136− # Generate cabal.project

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

138− - touch cabal.project

139− - |

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

141− - |

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

143− - cat cabal.project || true

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

145− # Building...

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

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

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

69+ - cabal test

148− # Building with tests and benchmarks...

70+ - cabal check

149− # build & run tests, build benchmarks

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

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

72+

151− # Testing...

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

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

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

153− # cabal check...

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

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

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

155− # haddock...

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

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

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

158− - rm -f cabal.project.local

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

160

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

162# EOF

79# EOF

CHANGELOG.md−149

@@ -1,152 +1,3 @@

1−2.5

2−---

3−

4−Highlights:

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

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

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

8−

9−Fixes and minor changes:

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

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

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

13−

14−2.4

15−---

16−

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

18−- Tags aren't sorted

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

20−- Schema type is optional

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

22−- Take concrete 'Proxy' as argument

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

24−- GHC-8.8 preparations

25−

26−2.3.1.1

27−-------

28−

29−- Allow `network-3.0`

30−

31−2.3.1

32−-----

33−

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

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

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

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

38−- Make nullary schemas valid

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

40−

41−2.3.0.1

42−-------

43−

44−- Support GHC-8.6

45−

46−2.3

47−---

48−

49−Major changes:

50−

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

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

53−

54−Dependencies and CI:

55−

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

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

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

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

60−

61−2.2.2

62−-----

63−

64−* Add `ToSchema Version` instance

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

66−* PVP bounds

67−

68−2.2.1

69−-----

70−

71−* Add `Semigroup` instances

72−* GHC-8.4 compatibility

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

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

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

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

77−

78−2.2

79−---

80−

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

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

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

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

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

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

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

88−

89−2.1.6

90−-----

91−

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

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

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

95−

96−2.1.5

97−-----

98−

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

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

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

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

103−

104−2.1.4.1

105−-------

106−

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

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

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

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

111−

112−2.1.4

113−-----

114−

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

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

117−

118−2.1.3

119−-----

120−

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

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

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

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

125−

126−2.1.2.1

127−-------

128−

129−* Bug fix previous release

130−

131−2.1.2

132−---

133−

134−* Minor changes:

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

136−

137−2.1.1

138−---

139−

140−* Minor changes:

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

142−

143−2.1

144−---

145−

146−* Major changes:

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

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

149−

1502.0.2

12.0.2

151---

2---

152

LICENSE+1−1

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

2All rights reserved.

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

README.md+1−3

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

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)

4−

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

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

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

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

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

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

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

14## Usage

12## Usage

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

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

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

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

Setup.hs−31

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

1−{-# LANGUAGE CPP #-}

2−{-# OPTIONS_GHC -Wall #-}

3−module Main (main) where

4−

5−#ifndef MIN_VERSION_cabal_doctest

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

7−#endif

8−

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

10−

11−import Distribution.Extra.Doctest ( defaultMainWithDoctests )

12−main :: IO ()

13−main = defaultMainWithDoctests "doctests"

14−

15−#else

16−

17−#ifdef MIN_VERSION_Cabal

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

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

20−--

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

22−-- workflow

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

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

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

26−#endif

27−

28import Distribution.Simple

1import Distribution.Simple

29−

30−main :: IO ()

31main = defaultMain

2main = defaultMain

32−

33−#endif

cabal.projectdeleted−2

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

1−packages: .

2−tests: true

examples/hackage.hs+1−15

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

20data UserSummary = UserSummary

21 { summaryUsername :: Username

22 , summaryUserid :: Int

23− } deriving (Generic)

23+ } deriving (Generic, ToSchema)

24−

25−instance ToSchema UserSummary where

26− declareNamedSchema _ = do

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

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

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

30− & type_ ?~ SwaggerObject

31− & properties .~

32− [ ("summaryUsername", usernameSchema )

33− , ("summaryUserid" , useridSchema )

34− ]

35− & required .~ [ "summaryUsername"

36− , "summaryUserid" ]

37−

39type Group = Text

25type Group = Text

hackage-docs.shdeleted−78

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

1−#!/bin/bash

2−set -e

3−

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

5−

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

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

8− exit 1

9−fi

10−

11−user=$1

12−

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

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

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

16− exit 1

17−fi

18−

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

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

21−

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

23− echo "Unable to determine package name"

24− exit 1

25−fi

26−

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

28− echo "Unable to determine package version"

29− exit 1

30−fi

31−

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

33−

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

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

36−

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

38−

39−ghc --version

40−cabal --version

41−stack --version

42−

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

44−then

45− echo "Using fancy hyperlinked source"

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

47−else

48− echo "Using boring hyperlinked source"

49− HYPERLINK_FLAG="--hyperlink-source"

50−fi

51−

52−# Cabal dist in temporary location

53−builddir=$dir/dist

54−

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

56−stack haddock --only-dependencies

57−

58−# Configure using stack databases

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

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

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

62−

63−# Build Hadckage compatible docs

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

65−

66−# Copy into right directory

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

68−

69−# Tar and gzip

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

71−

72−# Upload

73−curl -X PUT \

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

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

76− -u "$user" \

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

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

src/Data/Swagger.hs+3−65

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

1−{-# LANGUAGE CPP #-}

2-- |

1-- |

3-- Module: Data.Swagger

2-- Module: Data.Swagger

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

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

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

32 -- * Re-exports

31 -- * Re-exports

33 module Data.Swagger.Lens,

32 module Data.Swagger.Lens,

34− module Data.Swagger.Optics,

35 module Data.Swagger.Operation,

33 module Data.Swagger.Operation,

36 module Data.Swagger.ParamSchema,

34 module Data.Swagger.ParamSchema,

37 module Data.Swagger.Schema,

35 module Data.Swagger.Schema,

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

78 SwaggerItems(..),

76 SwaggerItems(..),

79 Xml(..),

77 Xml(..),

80 Pattern,

78 Pattern,

81− AdditionalProperties(..),

83 -- ** Responses

80 -- ** Responses

84 Responses(..),

81 Responses(..),

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

89 SecurityScheme(..),

86 SecurityScheme(..),

90 SecuritySchemeType(..),

87 SecuritySchemeType(..),

91 SecurityRequirement(..),

88 SecurityRequirement(..),

92− SecurityDefinitions(..),

94 -- *** API key

90 -- *** API key

95 ApiKeyParams(..),

91 ApiKeyParams(..),

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

114) where

110) where

115

111

116import Data.Swagger.Lens

112import Data.Swagger.Lens

117−import Data.Swagger.Optics ()

118import Data.Swagger.Operation

113import Data.Swagger.Operation

119import Data.Swagger.ParamSchema

114import Data.Swagger.ParamSchema

120import Data.Swagger.Schema

115import Data.Swagger.Schema

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

178

173

179-- $lens

174-- $lens

180--

175--

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

182−--

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

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

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

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

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

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

186--

179--

187-- >>> :{

180-- >>> :{

188-- encode $ (mempty :: Swagger)

181-- encode $ (mempty :: Swagger)

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

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

190-- & paths .~

183-- & paths .~

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

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

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

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

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

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

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

210-- >>> :{

203-- >>> :{

211-- encode $ (mempty :: Schema)

204-- encode $ (mempty :: Schema)

212−-- & type_ ?~ SwaggerBoolean

205+-- & type_ .~ SwaggerBoolean

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

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

214-- :}

207-- :}

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

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

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

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

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

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

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

220--

213--

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

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

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

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

223--

216--

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

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

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

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

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

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

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

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

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

282−--

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

284−-- schema for basic enums like

285−--

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

287−-- >>> instance ToSchema SampleEnum

288−-- >>> instance ToJSON SampleEnum

289−--

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

291−--

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

293−-- >>> instance ToSchema SampleSumType

294−-- >>> instance ToJSON SampleSumType

295−--

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

297−--

298−#if __GLASGOW_HASKELL__ < 800

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

300−-- >>> instance ToSchema BadMixedType

301−-- ...

302−-- ... error:

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

304−-- ... BadMixedType)

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

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

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

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

309−-- ... declareNamedSchema

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

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

312−#else

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

314−-- >>> instance ToSchema BadMixedType

315−-- ...

316−-- ... error:

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

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

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

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

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

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

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

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

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

326−-- ... declareNamedSchema

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

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

329−#endif

330−--

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

332−--

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

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

335−-- >>> instance ToJSON BadMixedType

336−--

337

275

338-- $manipulation

276-- $manipulation

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

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

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

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

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE UndecidableInstances #-}

6-- |

5-- |

7-- Module: Data.Swagger.Declare

6-- Module: Data.Swagger.Declare

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

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

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

15import Prelude.Compat

14import Prelude.Compat

17import Control.Monad

16import Control.Monad

18−import Control.Monad.Cont (ContT)

19−import Control.Monad.List (ListT)

20−import Control.Monad.Reader (ReaderT)

21import Control.Monad.Trans

17import Control.Monad.Trans

22−import Control.Monad.Trans.Except (ExceptT)

23−import Control.Monad.Trans.Identity (IdentityT)

24−import Control.Monad.Trans.Maybe (MaybeT)

25−import Control.Monad.Trans.State.Lazy as Lazy

26−import Control.Monad.Trans.State.Strict as Strict

27−import Control.Monad.Trans.RWS.Lazy as Lazy

28−import Control.Monad.Trans.RWS.Strict as Strict

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

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

31import Data.Functor.Identity

18import Data.Functor.Identity

19+import Data.Monoid

33-- | A declare monad transformer parametrized by:

21-- | A declare monad transformer parametrized by:

34--

22--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

92−-- | Lift a computation from the simple Declare monad.

93−liftDeclare :: MonadDeclare d m => Declare d a -> m a

94−liftDeclare da = do

95− (d', a) <- looks (runDeclare da)

96− declare d'

97− pure a

98−

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

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

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

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

101looks f = f <$> look

82looks f = f <$> look

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

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

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

145undeclare = runIdentity . undeclareT

126undeclare = runIdentity . undeclareT

146

127

147−-- ---------------------------------------------------------------------------

148−-- Instances for other mtl transformers

149−--

150−-- All of these instances need UndecidableInstances,

151−-- because they do not satisfy the coverage condition.

152−

153−instance MonadDeclare d m => MonadDeclare d (ContT r m) where

154− declare = lift . declare

155− look = lift look

156−

157−instance MonadDeclare d m => MonadDeclare d (ExceptT e m) where

158− declare = lift . declare

159− look = lift look

160−

161−instance MonadDeclare d m => MonadDeclare d (IdentityT m) where

162− declare = lift . declare

163− look = lift look

164−

165−instance MonadDeclare d m => MonadDeclare d (ListT m) where

166− declare = lift . declare

167− look = lift look

168−

169−instance MonadDeclare d m => MonadDeclare d (MaybeT m) where

170− declare = lift . declare

171− look = lift look

172−

173−instance MonadDeclare d m => MonadDeclare d (ReaderT r m) where

174− declare = lift . declare

175− look = lift look

176−

177−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.RWST r w s m) where

178− declare = lift . declare

179− look = lift look

180−

181−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.RWST r w s m) where

182− declare = lift . declare

183− look = lift look

184−

185−instance MonadDeclare d m => MonadDeclare d (Lazy.StateT s m) where

186− declare = lift . declare

187− look = lift look

188−

189−instance MonadDeclare d m => MonadDeclare d (Strict.StateT s m) where

190− declare = lift . declare

191− look = lift look

192−

193−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Lazy.WriterT w m) where

194− declare = lift . declare

195− look = lift look

196−

197−instance (Monoid w, MonadDeclare d m) => MonadDeclare d (Strict.WriterT w m) where

198− declare = lift . declare

199− look = lift look

src/Data/Swagger/Internal.hs+80−196

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

4{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE DeriveFunctor #-}

5{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

@@ -9,15 +8,15 @@

9{-# LANGUAGE GADTs #-}

8{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE RecordWildCards #-}

13{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE StandaloneDeriving #-}

15−{-# LANGUAGE TemplateHaskell #-}

16−{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

18−#if __GLASGOW_HASKELL__ <710

16+

17+{-# LANGUAGE DataKinds #-}

19−{-# LANGUAGE PolyKinds #-}

18+{-# LANGUAGE TypeFamilies #-}

20−#endif

19+{-# LANGUAGE TemplateHaskell #-}

21#include "overlapping-compat.h"

20#include "overlapping-compat.h"

22module Data.Swagger.Internal where

21module Data.Swagger.Internal where

@@ -26,22 +25,22 @@ import Prelude.Compat

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

26import Control.Lens ((&), (.~), (?~))

28import Control.Applicative

27import Control.Applicative

28+import Control.Monad

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)

32+import Data.HashMap.Strict (HashMap)

33import qualified Data.HashMap.Strict as HashMap

34−import Data.HashSet.InsOrd (InsOrdHashSet)

35import Data.Map (Map)

34import Data.Map (Map)

36import qualified Data.Map as Map

35import qualified Data.Map as Map

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

36+import Data.Monoid

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

39import Data.Scientific (Scientific)

37import Data.Scientific (Scientific)

38+import Data.Set (Set)

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

39import Data.String (IsString(..))

41import Data.Text (Text)

40import Data.Text (Text)

42import qualified Data.Text as Text

41import qualified Data.Text as Text

43import GHC.Generics (Generic)

42import GHC.Generics (Generic)

44−import Network.Socket (HostName, PortNumber)

43+import Network (HostName, PortNumber)

45import Network.HTTP.Media (MediaType)

44import Network.HTTP.Media (MediaType)

46import Text.Read (readMaybe)

45import Text.Read (readMaybe)

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

66#define DEFINE_TOENCODING

65#define DEFINE_TOENCODING

67#endif

66#endif

69−-- $setup

70−-- >>> :seti -XDataKinds

71−-- >>> import Data.Aeson

72−

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

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

74type Definitions = InsOrdHashMap Text

69type Definitions = InsOrdHashMap Text

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

117 , _swaggerResponses :: Definitions Response

112 , _swaggerResponses :: Definitions Response

118

113

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

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

120− , _swaggerSecurityDefinitions :: SecurityDefinitions

115+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme

121

116

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

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

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

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

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

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

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

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

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

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

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

133− , _swaggerTags :: InsOrdHashSet Tag

128+ , _swaggerTags :: Set Tag

134

129

135 -- | Additional external documentation.

130 -- | Additional external documentation.

136 , _swaggerExternalDocs :: Maybe ExternalDocs

131 , _swaggerExternalDocs :: Maybe ExternalDocs

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

252data Operation = Operation

247data Operation = Operation

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

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

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

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

255− _operationTags :: InsOrdHashSet TagName

250+ _operationTags :: Set TagName

256

251

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

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

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

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

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

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

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

310

305

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

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

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

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

313

308

314mimeListConstr :: Constr

309mimeListConstr :: Constr

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

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

@@ -360,7 +355,7 @@ data ParamOtherSchema = ParamOtherSchema

360 -- Default value is @False@.

355 -- Default value is @False@.

361 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool

356 , _paramOtherSchemaAllowEmptyValue :: Maybe Bool

362

357

363− , _paramOtherSchemaParamSchema :: ParamSchema 'SwaggerKindParamOtherSchema

358+ , _paramOtherSchemaParamSchema :: ParamSchema SwaggerKindParamOtherSchema

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

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

365

360

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

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

@@ -375,8 +370,8 @@ data ParamOtherSchema = ParamOtherSchema

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

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

376data SwaggerItems t where

371data SwaggerItems t where

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

372 SwaggerItemsPrimitive :: Maybe (CollectionFormat k) -> ParamSchema k-> SwaggerItems k

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

373+ SwaggerItemsObject :: Referenced Schema -> SwaggerItems SwaggerKindSchema

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

374+ SwaggerItemsArray :: [Referenced Schema] -> SwaggerItems SwaggerKindSchema

380 deriving (Typeable)

375 deriving (Typeable)

381

376

382deriving instance Eq (SwaggerItems t)

377deriving instance Eq (SwaggerItems t)

@@ -398,7 +393,7 @@ swaggerItemsDataType = mkDataType "Data.Swagger.SwaggerItems" [swaggerItemsPrimi

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

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

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

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

400

395

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

396+instance Data t => Data (SwaggerItems (SwaggerKindNormal t)) where

402 -- TODO: define gfoldl

397 -- TODO: define gfoldl

403 gunfold k z c = case constrIndex c of

398 gunfold k z c = case constrIndex c of

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

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

@@ -407,7 +402,7 @@ instance Data t => Data (SwaggerItems ('SwaggerKindNormal t)) where

407 dataTypeOf _ = swaggerItemsDataType

402 dataTypeOf _ = swaggerItemsDataType

408

403

409-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only

404-- SwaggerItems SwaggerKindParamOtherSchema can be constructed using SwaggerItemsPrimitive only

410−instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where

405+instance Data (SwaggerItems SwaggerKindParamOtherSchema) where

411 -- TODO: define gfoldl

406 -- TODO: define gfoldl

412 gunfold k z c = case constrIndex c of

407 gunfold k z c = case constrIndex c of

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

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

@@ -415,19 +410,18 @@ instance Data (SwaggerItems 'SwaggerKindParamOtherSchema) where

415 toConstr _ = swaggerItemsPrimitiveConstr

410 toConstr _ = swaggerItemsPrimitiveConstr

416 dataTypeOf _ = swaggerItemsDataType

411 dataTypeOf _ = swaggerItemsDataType

417

412

418−instance Data (SwaggerItems 'SwaggerKindSchema) where

413+instance Data (SwaggerItems SwaggerKindSchema) where

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

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

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

415 gfoldl k z (SwaggerItemsObject ref) = z SwaggerItemsObject `k` ref

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

416 gfoldl k z (SwaggerItemsArray ref) = z SwaggerItemsArray `k` ref

422

417

423 gunfold k z c = case constrIndex c of

418 gunfold k z c = case constrIndex c of

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

424 2 -> k (z SwaggerItemsObject)

420 2 -> k (z SwaggerItemsObject)

425 3 -> k (z SwaggerItemsArray)

421 3 -> k (z SwaggerItemsArray)

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

427

422

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

429− toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr

423+ toConstr (SwaggerItemsObject _) = swaggerItemsObjectConstr

430− toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr

424+ toConstr (SwaggerItemsArray _) = swaggerItemsArrayConstr

431

425

432 dataTypeOf _ = swaggerItemsDataType

426 dataTypeOf _ = swaggerItemsDataType

433

427

@@ -436,16 +430,17 @@ data SwaggerKind t

436 = SwaggerKindNormal t

430 = SwaggerKindNormal t

437 | SwaggerKindParamOtherSchema

431 | SwaggerKindParamOtherSchema

438 | SwaggerKindSchema

432 | SwaggerKindSchema

439− deriving (Typeable)

440

433

434+#if __GLASGLOW_HASKELL__ < 710

441deriving instance Typeable 'SwaggerKindNormal

435deriving instance Typeable 'SwaggerKindNormal

442deriving instance Typeable 'SwaggerKindParamOtherSchema

436deriving instance Typeable 'SwaggerKindParamOtherSchema

443deriving instance Typeable 'SwaggerKindSchema

437deriving instance Typeable 'SwaggerKindSchema

438+#endif

444

439

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

440type family SwaggerKindType (k :: SwaggerKind *) :: *

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

441+type instance SwaggerKindType (SwaggerKindNormal t) = t

447−type instance SwaggerKindType 'SwaggerKindSchema = Schema

442+type instance SwaggerKindType SwaggerKindSchema = Schema

448−type instance SwaggerKindType 'SwaggerKindParamOtherSchema = ParamOtherSchema

443+type instance SwaggerKindType SwaggerKindParamOtherSchema = ParamOtherSchema

449

444

450data SwaggerType t where

445data SwaggerType t where

451 SwaggerString :: SwaggerType t

446 SwaggerString :: SwaggerType t

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

453 SwaggerInteger :: SwaggerType t

448 SwaggerInteger :: SwaggerType t

454 SwaggerBoolean :: SwaggerType t

449 SwaggerBoolean :: SwaggerType t

455 SwaggerArray :: SwaggerType t

450 SwaggerArray :: SwaggerType t

456− SwaggerFile :: SwaggerType 'SwaggerKindParamOtherSchema

451+ SwaggerFile :: SwaggerType SwaggerKindParamOtherSchema

457− SwaggerNull :: SwaggerType 'SwaggerKindSchema

452+ SwaggerNull :: SwaggerType SwaggerKindSchema

458− SwaggerObject :: SwaggerType 'SwaggerKindSchema

453+ SwaggerObject :: SwaggerType SwaggerKindSchema

459 deriving (Typeable)

454 deriving (Typeable)

460

455

461deriving instance Eq (SwaggerType t)

456deriving instance Eq (SwaggerType t)

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

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

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

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

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

466

461

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

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

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

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

469

464

470swaggerCommonTypes :: [SwaggerType k]

465swaggerCommonTypes :: [SwaggerType k]

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

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

472

467

473−swaggerParamTypes :: [SwaggerType 'SwaggerKindParamOtherSchema]

468+swaggerParamTypes :: [SwaggerType SwaggerKindParamOtherSchema]

474swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]

469swaggerParamTypes = swaggerCommonTypes ++ [SwaggerFile]

475

470

476−swaggerSchemaTypes :: [SwaggerType 'SwaggerKindSchema]

471+swaggerSchemaTypes :: [SwaggerType SwaggerKindSchema]

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

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

478

473

479swaggerTypeConstrs :: [Constr]

474swaggerTypeConstrs :: [Constr]

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

475+swaggerTypeConstrs = map swaggerTypeConstr (swaggerCommonTypes :: [SwaggerType SwaggerKindSchema])

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

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

482

477

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

478+instance Typeable t => Data (SwaggerType (SwaggerKindNormal t)) where

484 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes

479 gunfold = gunfoldEnum "SwaggerType" swaggerCommonTypes

485 toConstr = swaggerTypeConstr

480 toConstr = swaggerTypeConstr

486 dataTypeOf = swaggerTypeDataType

481 dataTypeOf = swaggerTypeDataType

487

482

488−instance Data (SwaggerType 'SwaggerKindParamOtherSchema) where

483+instance Data (SwaggerType SwaggerKindParamOtherSchema) where

489 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes

484 gunfold = gunfoldEnum "SwaggerType ParamOtherSchema" swaggerParamTypes

490 toConstr = swaggerTypeConstr

485 toConstr = swaggerTypeConstr

491 dataTypeOf = swaggerTypeDataType

486 dataTypeOf = swaggerTypeDataType

492

487

493−instance Data (SwaggerType 'SwaggerKindSchema) where

488+instance Data (SwaggerType SwaggerKindSchema) where

494 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes

489 gunfold = gunfoldEnum "SwaggerType Schema" swaggerSchemaTypes

495 toConstr = swaggerTypeConstr

490 toConstr = swaggerTypeConstr

496 dataTypeOf = swaggerTypeDataType

491 dataTypeOf = swaggerTypeDataType

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

530 -- Corresponds to multiple parameter instances

525 -- Corresponds to multiple parameter instances

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

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

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

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

533− CollectionMulti :: CollectionFormat 'SwaggerKindParamOtherSchema

528+ CollectionMulti :: CollectionFormat SwaggerKindParamOtherSchema

534 deriving (Typeable)

529 deriving (Typeable)

535

530

536deriving instance Eq (CollectionFormat t)

531deriving instance Eq (CollectionFormat t)

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

546collectionCommonFormats :: [CollectionFormat t]

541collectionCommonFormats :: [CollectionFormat t]

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

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

548

543

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

544+instance Data t => Data (CollectionFormat (SwaggerKindNormal t)) where

550 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats

545 gunfold = gunfoldEnum "CollectionFormat" collectionCommonFormats

551 toConstr = collectionFormatConstr

546 toConstr = collectionFormatConstr

552 dataTypeOf _ = collectionFormatDataType

547 dataTypeOf _ = collectionFormatDataType

553

548

554−deriving instance Data (CollectionFormat 'SwaggerKindParamOtherSchema)

549+deriving instance Data (CollectionFormat SwaggerKindParamOtherSchema)

555

550

556type ParamName = Text

551type ParamName = Text

557

552

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

560 , _schemaDescription :: Maybe Text

555 , _schemaDescription :: Maybe Text

561 , _schemaRequired :: [ParamName]

556 , _schemaRequired :: [ParamName]

562

557

563− , _schemaAllOf :: Maybe [Referenced Schema]

558+ , _schemaAllOf :: Maybe [Schema]

564 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

559 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

565− , _schemaAdditionalProperties :: Maybe AdditionalProperties

560+ , _schemaAdditionalProperties :: Maybe (Referenced Schema)

566

561

567 , _schemaDiscriminator :: Maybe Text

562 , _schemaDiscriminator :: Maybe Text

568 , _schemaReadOnly :: Maybe Bool

563 , _schemaReadOnly :: Maybe Bool

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

573 , _schemaMaxProperties :: Maybe Integer

568 , _schemaMaxProperties :: Maybe Integer

574 , _schemaMinProperties :: Maybe Integer

569 , _schemaMinProperties :: Maybe Integer

575

570

576− , _schemaParamSchema :: ParamSchema 'SwaggerKindSchema

571+ , _schemaParamSchema :: ParamSchema SwaggerKindSchema

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

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

578

573

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

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

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

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

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

595 _paramSchemaDefault :: Maybe Value

590 _paramSchemaDefault :: Maybe Value

596

591

597− , _paramSchemaType :: Maybe (SwaggerType t)

592+ , _paramSchemaType :: SwaggerType t

598 , _paramSchemaFormat :: Maybe Format

593 , _paramSchemaFormat :: Maybe Format

599 , _paramSchemaItems :: Maybe (SwaggerItems t)

594 , _paramSchemaItems :: Maybe (SwaggerItems t)

600 , _paramSchemaMaximum :: Maybe Scientific

595 , _paramSchemaMaximum :: Maybe Scientific

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

611 , _paramSchemaMultipleOf :: Maybe Scientific

606 , _paramSchemaMultipleOf :: Maybe Scientific

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

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

613

608

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

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

615

610

616data Xml = Xml

611data Xml = Xml

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

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

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

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

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

688 _headerDescription :: Maybe Text

683 _headerDescription :: Maybe Text

689

684

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

685+ , _headerParamSchema :: ParamSchema (SwaggerKindNormal Header)

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

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

692

687

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

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

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

755 , _securitySchemeDescription :: Maybe Text

750 , _securitySchemeDescription :: Maybe Text

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

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

757

752

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−

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

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

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

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

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

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

777newtype SecurityRequirement = SecurityRequirement

756newtype SecurityRequirement = SecurityRequirement

778 { getSecurityRequirement :: InsOrdHashMap Text [Text]

757 { getSecurityRequirement :: InsOrdHashMap Text [Text]

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

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

780

759

781-- | Tag name.

760-- | Tag name.

782type TagName = Text

761type TagName = Text

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

795 , _tagExternalDocs :: Maybe ExternalDocs

774 , _tagExternalDocs :: Maybe ExternalDocs

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

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

797

776

798−instance Hashable Tag

799−

800instance IsString Tag where

777instance IsString Tag where

801 fromString s = Tag (fromString s) Nothing Nothing

778 fromString s = Tag (fromString s) Nothing Nothing

802

779

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

810 , _externalDocsUrl :: URL

787 , _externalDocsUrl :: URL

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

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

812

789

813−instance Hashable ExternalDocs

814−

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

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

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

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

817newtype Reference = Reference { getReference :: Text }

792newtype Reference = Reference { getReference :: Text }

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

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

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

826 fromString = Inline . fromString

801 fromString = Inline . fromString

827

802

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

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

829−

830−data AdditionalProperties

831− = AdditionalPropertiesAllowed Bool

832− | AdditionalPropertiesSchema (Referenced Schema)

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

834

804

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

805-- =======================================================================

836-- Monoid instances

806-- Monoid instances

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

807-- =======================================================================

838

808

839−instance Semigroup Swagger where

840− (<>) = genericMappend

841instance Monoid Swagger where

809instance Monoid Swagger where

842 mempty = genericMempty

810 mempty = genericMempty

843− mappend = (<>)

811+ mappend = genericMappend

844

812

845−instance Semigroup Info where

846− (<>) = genericMappend

847instance Monoid Info where

813instance Monoid Info where

848 mempty = genericMempty

814 mempty = genericMempty

849− mappend = (<>)

815+ mappend = genericMappend

850

816

851−instance Semigroup Contact where

852− (<>) = genericMappend

853instance Monoid Contact where

817instance Monoid Contact where

854 mempty = genericMempty

818 mempty = genericMempty

855− mappend = (<>)

819+ mappend = genericMappend

856

820

857−instance Semigroup PathItem where

858− (<>) = genericMappend

859instance Monoid PathItem where

821instance Monoid PathItem where

860 mempty = genericMempty

822 mempty = genericMempty

861− mappend = (<>)

823+ mappend = genericMappend

862

824

863−instance Semigroup Schema where

864− (<>) = genericMappend

865instance Monoid Schema where

825instance Monoid Schema where

866 mempty = genericMempty

826 mempty = genericMempty

867− mappend = (<>)

827+ mappend = genericMappend

868

828

869−instance Semigroup (ParamSchema t) where

870− (<>) = genericMappend

871instance Monoid (ParamSchema t) where

829instance Monoid (ParamSchema t) where

872 mempty = genericMempty

830 mempty = genericMempty

873− mappend = (<>)

831+ mappend = genericMappend

874

832

875−instance Semigroup Param where

876− (<>) = genericMappend

877instance Monoid Param where

833instance Monoid Param where

878 mempty = genericMempty

834 mempty = genericMempty

879− mappend = (<>)

835+ mappend = genericMappend

880

836

881−instance Semigroup ParamOtherSchema where

882− (<>) = genericMappend

883instance Monoid ParamOtherSchema where

837instance Monoid ParamOtherSchema where

884 mempty = genericMempty

838 mempty = genericMempty

885− mappend = (<>)

839+ mappend = genericMappend

886

840

887−instance Semigroup Header where

888− (<>) = genericMappend

889instance Monoid Header where

841instance Monoid Header where

890 mempty = genericMempty

842 mempty = genericMempty

891− mappend = (<>)

843+ mappend = genericMappend

892

844

893−instance Semigroup Responses where

894− (<>) = genericMappend

895instance Monoid Responses where

845instance Monoid Responses where

896 mempty = genericMempty

846 mempty = genericMempty

897− mappend = (<>)

847+ mappend = genericMappend

898

848

899−instance Semigroup Response where

900− (<>) = genericMappend

901instance Monoid Response where

849instance Monoid Response where

902 mempty = genericMempty

850 mempty = genericMempty

903− mappend = (<>)

851+ mappend = genericMappend

904

852

905−instance Semigroup ExternalDocs where

906− (<>) = genericMappend

907instance Monoid ExternalDocs where

853instance Monoid ExternalDocs where

908 mempty = genericMempty

854 mempty = genericMempty

909− mappend = (<>)

855+ mappend = genericMappend

910

856

911−instance Semigroup Operation where

912− (<>) = genericMappend

913instance Monoid Operation where

857instance Monoid Operation where

914 mempty = genericMempty

858 mempty = genericMempty

915− mappend = (<>)

859+ mappend = genericMappend

916

860

917−instance Semigroup Example where

918− (<>) = genericMappend

919instance Monoid Example where

861instance Monoid Example where

920 mempty = genericMempty

862 mempty = genericMempty

921− mappend = (<>)

863+ mappend = genericMappend

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

933

864

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

865-- =======================================================================

935-- SwaggerMonoid helper instances

866-- SwaggerMonoid helper instances

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

945instance SwaggerMonoid Response

876instance SwaggerMonoid Response

946instance SwaggerMonoid ExternalDocs

877instance SwaggerMonoid ExternalDocs

947instance SwaggerMonoid Operation

878instance SwaggerMonoid Operation

948−instance SwaggerMonoid SecurityDefinitions

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

950

879

951instance SwaggerMonoid MimeList

880instance SwaggerMonoid MimeList

952deriving instance SwaggerMonoid URL

881deriving instance SwaggerMonoid URL

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

965

894

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

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

967 swaggerMempty = Inline mempty

896 swaggerMempty = Inline mempty

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

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

969 swaggerMappend _ y = y

898 swaggerMappend _ y = y

970

899

971instance SwaggerMonoid ParamAnySchema where

900instance SwaggerMonoid ParamAnySchema where

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

1088 toJSON = sopSwaggerGenericToJSON

1017 toJSON = sopSwaggerGenericToJSON

1089 DEFINE_TOENCODING

1018 DEFINE_TOENCODING

1090

1019

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

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

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

1098 toJSON (SwaggerItemsPrimitive fmt schema) = object

1021 toJSON (SwaggerItemsPrimitive fmt schema) = object

1099 [ "collectionFormat" .= fmt

1022 [ "collectionFormat" .= fmt

1100 , "items" .= schema ]

1023 , "items" .= schema ]

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

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

1102− toJSON (SwaggerItemsArray []) = object

1103− [ "items" .= object []

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

1105− , "example" .= Array mempty

1106− ]

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

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

1108

1026

1109instance ToJSON Host where

1027instance ToJSON Host where

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

1146instance ToJSON Example where

1064instance ToJSON Example where

1147 toJSON = toJSON . Map.mapKeys show . getExample

1065 toJSON = toJSON . Map.mapKeys show . getExample

1148

1066

1149−instance ToJSON SecurityDefinitions where

1150− toJSON (SecurityDefinitions sd) = toJSON sd

1151−

1152instance ToJSON Reference where

1067instance ToJSON Reference where

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

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

1154

1069

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

1182 toJSON = sopSwaggerGenericToJSONWithOpts $

1097 toJSON = sopSwaggerGenericToJSONWithOpts $

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

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

1184

1099

1185−instance ToJSON AdditionalProperties where

1186− toJSON (AdditionalPropertiesAllowed b) = toJSON b

1187− toJSON (AdditionalPropertiesSchema s) = toJSON s

1188−

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

1100-- =======================================================================

1190-- Manual FromJSON instances

1101-- Manual FromJSON instances

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

1102-- =======================================================================

@@ -1223,42 +1134,23 @@ instance FromJSON SecurityScheme where

1223 parseJSON = sopSwaggerGenericParseJSON

1134 parseJSON = sopSwaggerGenericParseJSON

1224

1135

1225instance FromJSON Schema where

1136instance FromJSON Schema where

1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON

1137+ parseJSON = 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

1233

1138

1234instance FromJSON Header where

1139instance FromJSON Header where

1235 parseJSON = sopSwaggerGenericParseJSON

1140 parseJSON = sopSwaggerGenericParseJSON

1236

1141

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

1142+instance (FromJSON (CollectionFormat (SwaggerKindNormal t)), FromJSON (ParamSchema (SwaggerKindNormal t))) => FromJSON (SwaggerItems (SwaggerKindNormal t)) where

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

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

1239 <$> o .:? "collectionFormat"

1144 <$> o .:? "collectionFormat"

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

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

1241

1146

1242−instance FromJSON (SwaggerItems 'SwaggerKindParamOtherSchema) where

1147+instance FromJSON (SwaggerItems SwaggerKindParamOtherSchema) where

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

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

1244 <$> o .:? "collectionFormat"

1149 <$> o .:? "collectionFormat"

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

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

1246

1151

1247−-- |

1248−--

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

1250−-- Just (SwaggerItemsArray [])

1251−--

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

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

1254−--

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

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

1257−--

1258−instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1152+instance FromJSON (SwaggerItems SwaggerKindSchema) where

1259− parseJSON js@(Object obj)

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

1261− | otherwise = SwaggerItemsObject <$> parseJSON js

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

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

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

1263 parseJSON _ = empty

1155 parseJSON _ = empty

1264

1156

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

1310instance FromJSON PathItem where

1202instance FromJSON PathItem where

1311 parseJSON = sopSwaggerGenericParseJSON

1203 parseJSON = sopSwaggerGenericParseJSON

1312

1204

1313−instance FromJSON SecurityDefinitions where

1314− parseJSON js = SecurityDefinitions <$> parseJSON js

1315−

1316instance FromJSON Reference where

1205instance FromJSON Reference where

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

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

1318 parseJSON _ = empty

1207 parseJSON _ = empty

@@ -1337,36 +1226,32 @@ instance FromJSON (Referenced Response) where parseJSON = referencedParseJSON "#

1337instance FromJSON Xml where

1226instance FromJSON Xml where

1338 parseJSON = genericParseJSON (jsonPrefix "xml")

1227 parseJSON = genericParseJSON (jsonPrefix "xml")

1339

1228

1340−instance FromJSON (SwaggerType 'SwaggerKindSchema) where

1229+instance FromJSON (SwaggerType SwaggerKindSchema) where

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

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

1342

1231

1343−instance FromJSON (SwaggerType 'SwaggerKindParamOtherSchema) where

1232+instance FromJSON (SwaggerType SwaggerKindParamOtherSchema) where

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

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

1345

1234

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

1235+instance FromJSON (SwaggerType (SwaggerKindNormal t)) where

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

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

1348

1237

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

1238+instance FromJSON (CollectionFormat (SwaggerKindNormal t)) where

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

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

1351

1240

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

1241-- NOTE: There aren't collections of 'Schema'

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

1242--instance FromJSON (CollectionFormat (SwaggerKindSchema)) where

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

1243-- parseJSON = parseOneOf [CollectionCSV, CollectionSSV, CollectionTSV, CollectionPipes]

1355

1244

1356−instance FromJSON (CollectionFormat 'SwaggerKindParamOtherSchema) where

1245+instance FromJSON (CollectionFormat SwaggerKindParamOtherSchema) where

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

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

1358

1247

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

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

1360 parseJSON = sopSwaggerGenericParseJSON

1249 parseJSON = sopSwaggerGenericParseJSON

1361−instance FromJSON (ParamSchema 'SwaggerKindParamOtherSchema) where

1250+instance FromJSON (ParamSchema SwaggerKindParamOtherSchema) where

1362 parseJSON = sopSwaggerGenericParseJSON

1251 parseJSON = sopSwaggerGenericParseJSON

1363−instance FromJSON (ParamSchema 'SwaggerKindSchema) where

1252+instance FromJSON (ParamSchema SwaggerKindSchema) where

1364 parseJSON = sopSwaggerGenericParseJSON

1253 parseJSON = sopSwaggerGenericParseJSON

1365

1254

1366−instance FromJSON AdditionalProperties where

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

1368− parseJSON js = AdditionalPropertiesSchema <$> parseJSON js

1369−

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

1255-------------------------------------------------------------------------------

1371-- TH splices

1256-- TH splices

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

1257-------------------------------------------------------------------------------

@@ -1407,12 +1292,12 @@ instance HasSwaggerAesonOptions Schema where

1407instance HasSwaggerAesonOptions Swagger where

1292instance HasSwaggerAesonOptions Swagger where

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

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

1409

1294

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

1295+instance HasSwaggerAesonOptions (ParamSchema (SwaggerKindNormal t)) where

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

1296 swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

1412−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindParamOtherSchema) where

1297+instance HasSwaggerAesonOptions (ParamSchema SwaggerKindParamOtherSchema) where

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

1298 swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema" & saoSubObject ?~ "items"

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

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

1415−instance HasSwaggerAesonOptions (ParamSchema 'SwaggerKindSchema) where

1300+instance HasSwaggerAesonOptions (ParamSchema SwaggerKindSchema) where

1416 swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"

1301 swaggerAesonOptions _ = mkSwaggerAesonOptions "paramSchema"

1417

1302

1418instance AesonDefaultValue (ParamSchema s)

1303instance AesonDefaultValue (ParamSchema s)

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

1424instance AesonDefaultValue MimeList where defaultValue = Just mempty

1309instance AesonDefaultValue MimeList where defaultValue = Just mempty

1425instance AesonDefaultValue Info

1310instance AesonDefaultValue Info

1426instance AesonDefaultValue ParamLocation

1311instance AesonDefaultValue ParamLocation

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

src/Data/Swagger/Internal/AesonUtils.hs+11−36

@@ -5,9 +5,6 @@

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ExplicitForAll #-}

7{-# LANGUAGE TemplateHaskell #-}

8−#if __GLASGOW_HASKELL__ >= 800

9−{-# LANGUAGE UndecidableSuperClasses #-}

10−#endif

11module Data.Swagger.Internal.AesonUtils (

8module Data.Swagger.Internal.AesonUtils (

12 -- * Generic functions

9 -- * Generic functions

13 AesonDefaultValue(..),

10 AesonDefaultValue(..),

@@ -35,7 +32,6 @@ import Control.Monad (unless)

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

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

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

33import Data.Aeson.Types (Parser, Pair)

37import Data.Char (toLower, isUpper)

34import Data.Char (toLower, isUpper)

38−import Data.Foldable (traverse_)

39import Data.Text (Text)

35import Data.Text (Text)

41import Generics.SOP

37import Generics.SOP

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

44import qualified Data.HashMap.Strict as HM

40import qualified Data.HashMap.Strict as HM

45import qualified Data.Set as Set

41import qualified Data.Set as Set

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

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

47−import qualified Data.HashSet.InsOrd as InsOrdHS

49#if MIN_VERSION_aeson(0,10,0)

44#if MIN_VERSION_aeson(0,10,0)

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

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

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

47+import Data.Foldable (foldMap)

51#endif

48#endif

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

50-------------------------------------------------------------------------------

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

68makeLenses ''SwaggerAesonOptions

65makeLenses ''SwaggerAesonOptions

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

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

71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

68+ swaggerAesonOptions :: proxy a -> SwaggerAesonOptions

73 -- So far we use only default definitions

70 -- So far we use only default definitions

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

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

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

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

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

74-------------------------------------------------------------------------------

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

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

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

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

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

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

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

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

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

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

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

88-------------------------------------------------------------------------------

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

102-- * possible to merge sub-object

98-- * possible to merge sub-object

103sopSwaggerGenericToJSON

99sopSwaggerGenericToJSON

104 :: forall a xs.

100 :: forall a xs.

101+ ( Generic a

105− ( HasDatatypeInfo a

102+ , HasDatatypeInfo a

106 , HasSwaggerAesonOptions a

103 , HasSwaggerAesonOptions a

107 , All2 ToJSON (Code a)

104 , All2 ToJSON (Code a)

108 , All2 Eq (Code a)

105 , All2 Eq (Code a)

@@ -146,13 +143,8 @@ sopSwaggerGenericToJSON'

146 -> DatatypeInfo '[xs]

143 -> DatatypeInfo '[xs]

147 -> POP Maybe '[xs]

144 -> POP Maybe '[xs]

148 -> [Pair]

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

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

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

153−#endif

154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

147 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

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

156

148

157sopSwaggerGenericToJSON''

149sopSwaggerGenericToJSON''

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

150 :: (All ToJSON xs, All Eq xs)

@@ -179,9 +171,6 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go

179 json = toJSON x

171 json = toJSON x

180 name' = fieldNameModifier name

172 name' = fieldNameModifier name

181 rest = go xs names defs

173 rest = go xs names defs

182−#if __GLASGOW_HASKELL__ < 800

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

184−#endif

185

174

186 fieldNameModifier = modifier . drop 1

175 fieldNameModifier = modifier . drop 1

187 modifier = lowerFirstUppers . drop (length prefix)

176 modifier = lowerFirstUppers . drop (length prefix)

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

194

183

195sopSwaggerGenericParseJSON

184sopSwaggerGenericParseJSON

196 :: forall a xs.

185 :: forall a xs.

186+ ( Generic a

197− ( HasDatatypeInfo a

187+ , HasDatatypeInfo a

198 , HasSwaggerAesonOptions a

188 , HasSwaggerAesonOptions a

199 , All2 FromJSON (Code a)

189 , All2 FromJSON (Code a)

200 , All2 Eq (Code a)

190 , All2 Eq (Code a)

@@ -205,7 +195,7 @@ sopSwaggerGenericParseJSON

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

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

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

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

207 in do

197 in do

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

198+ traverse (parseAdditionalField obj) (opts ^. saoAdditionalPairs)

209 to <$> ps

199 to <$> ps

210 where

200 where

211 proxy = Proxy :: Proxy a

201 proxy = Proxy :: Proxy a

@@ -226,13 +216,8 @@ sopSwaggerGenericParseJSON'

226 -> DatatypeInfo '[xs]

216 -> DatatypeInfo '[xs]

227 -> POP Maybe '[xs]

217 -> POP Maybe '[xs]

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

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

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

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

233−#endif

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

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

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

236

221

237sopSwaggerGenericParseJSON''

222sopSwaggerGenericParseJSON''

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

223 :: (All FromJSON xs, All Eq xs)

@@ -260,9 +245,6 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go

260 withDef = case def of

245 withDef = case def of

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

246 Just def' -> (<|> pure def')

262 Nothing -> id

247 Nothing -> id

263−#if __GLASGOW_HASKELL__ < 800

264− go _ _ = error "not empty"

265−#endif

266

248

267 fieldNameModifier = modifier . drop 1

249 fieldNameModifier = modifier . drop 1

268 modifier = lowerFirstUppers . drop (length prefix)

250 modifier = lowerFirstUppers . drop (length prefix)

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

277

259

278sopSwaggerGenericToEncoding

260sopSwaggerGenericToEncoding

279 :: forall a xs.

261 :: forall a xs.

262+ ( Generic a

280− ( HasDatatypeInfo a

263+ , HasDatatypeInfo a

281 , HasSwaggerAesonOptions a

264 , HasSwaggerAesonOptions a

282 , All2 ToJSON (Code a)

265 , All2 ToJSON (Code a)

283 , All2 Eq (Code a)

266 , All2 Eq (Code a)

@@ -302,13 +285,8 @@ sopSwaggerGenericToEncoding'

302 -> DatatypeInfo '[xs]

285 -> DatatypeInfo '[xs]

303 -> POP Maybe '[xs]

286 -> POP Maybe '[xs]

304 -> Series

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

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

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

309−#endif

310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

289 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

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

312

290

313sopSwaggerGenericToEncoding''

291sopSwaggerGenericToEncoding''

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

292 :: (All ToJSON xs, All Eq xs)

@@ -334,9 +312,6 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go

334 where

312 where

335 name' = fieldNameModifier name

313 name' = fieldNameModifier name

336 rest = go xs names defs

314 rest = go xs names defs

337−#if __GLASGOW_HASKELL__ < 800

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

339−#endif

340

315

341 fieldNameModifier = modifier . drop 1

316 fieldNameModifier = modifier . drop 1

342 modifier = lowerFirstUppers . drop (length prefix)

317 modifier = lowerFirstUppers . drop (length prefix)

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

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DefaultSignatures #-}

2{-# LANGUAGE DefaultSignatures #-}

4{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

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

8{-# LANGUAGE PackageImports #-}

7{-# LANGUAGE PackageImports #-}

9{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeSynonymInstances #-}

11{-# LANGUAGE TypeSynonymInstances #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−#if __GLASGOW_HASKELL__ >= 800

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

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

18−-- For TypeErrors

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

20−#endif

21#include "overlapping-compat.h"

12#include "overlapping-compat.h"

22module Data.Swagger.Internal.ParamSchema where

13module Data.Swagger.Internal.ParamSchema where

24import Control.Lens

15import Control.Lens

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

16+import Data.Aeson

26import Data.Proxy

17import Data.Proxy

27import GHC.Generics

18import GHC.Generics

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

31import Data.Monoid

22import Data.Monoid

32import Data.Set (Set)

23import Data.Set (Set)

33import Data.Scientific

24import Data.Scientific

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

35import qualified Data.Text as T

25import qualified Data.Text as T

36import qualified Data.Text.Lazy as TL

26import qualified Data.Text.Lazy as TL

37import Data.Time

27import Data.Time

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

39import qualified Data.Vector.Primitive as VP

29import qualified Data.Vector.Primitive as VP

40import qualified Data.Vector.Storable as VS

30import qualified Data.Vector.Storable as VS

41import qualified Data.Vector.Unboxed as VU

31import qualified Data.Vector.Unboxed as VU

42−import Data.Version (Version)

43−import Numeric.Natural.Compat (Natural)

44import Data.Word

32import Data.Word

45−import Data.UUID.Types (UUID)

46−import Web.Cookie (SetCookie)

48import Data.Swagger.Internal

34import Data.Swagger.Internal

49import Data.Swagger.Lens

35import Data.Swagger.Lens

50import Data.Swagger.SchemaOptions

36import Data.Swagger.SchemaOptions

52−#if __GLASGOW_HASKELL__ < 800

53−#else

54−import qualified Data.ByteString as BS

55−import qualified Data.ByteString.Lazy as BSL

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

57−#endif

58−

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

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

60binaryParamSchema :: ParamSchema t

39binaryParamSchema :: ParamSchema t

61binaryParamSchema = mempty

40binaryParamSchema = mempty

62− & type_ ?~ SwaggerString

41+ & type_ .~ SwaggerString

63 & format ?~ "binary"

42 & format ?~ "binary"

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

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

66byteParamSchema :: ParamSchema t

45byteParamSchema :: ParamSchema t

67byteParamSchema = mempty

46byteParamSchema = mempty

68− & type_ ?~ SwaggerString

47+ & type_ .~ SwaggerString

69 & format ?~ "byte"

48 & format ?~ "byte"

71-- | Default schema for password string.

50-- | Default schema for password string.

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

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

73passwordParamSchema :: ParamSchema t

52passwordParamSchema :: ParamSchema t

74passwordParamSchema = mempty

53passwordParamSchema = mempty

75− & type_ ?~ SwaggerString

54+ & type_ .~ SwaggerString

76 & format ?~ "password"

55 & format ?~ "password"

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

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

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

87-- data Direction = Up | Down

66-- data Direction = Up | Down

88--

67--

89-- instance ToParamSchema Direction where

68-- instance ToParamSchema Direction where

90−-- toParamSchema _ = mempty

69+-- toParamSchema = mempty

91−-- & type_ ?~ SwaggerString

70+-- & type_ .~ SwaggerString

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

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

93-- @

72-- @

94--

73--

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

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

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

115 --

94 --

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

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

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

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

118− toParamSchema :: Proxy a -> ParamSchema t

97+ toParamSchema :: proxy a -> ParamSchema t

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

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

120 toParamSchema = genericToParamSchema defaultSchemaOptions

99 toParamSchema = genericToParamSchema defaultSchemaOptions

121

100

122instance OVERLAPPING_ ToParamSchema String where

101instance OVERLAPPING_ ToParamSchema String where

123− toParamSchema _ = mempty & type_ ?~ SwaggerString

102+ toParamSchema _ = mempty & type_ .~ SwaggerString

124

103

125instance ToParamSchema Bool where

104instance ToParamSchema Bool where

126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

105+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean

127

106

128instance ToParamSchema Integer where

107instance ToParamSchema Integer where

129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger

108+ toParamSchema _ = mempty & type_ .~ SwaggerInteger

130−

131−instance ToParamSchema Natural where

132− toParamSchema _ = mempty

133− & type_ ?~ SwaggerInteger

134− & minimum_ ?~ 0

135− & exclusiveMinimum ?~ False

136

109

137instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral

110instance ToParamSchema Int where toParamSchema = toParamSchemaBoundedIntegral

138instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral

111instance ToParamSchema Int8 where toParamSchema = toParamSchemaBoundedIntegral

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

154--

127--

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

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

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

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

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

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

158toParamSchemaBoundedIntegral _ = mempty

131toParamSchemaBoundedIntegral _ = mempty

159− & type_ ?~ SwaggerInteger

132+ & type_ .~ SwaggerInteger

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

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

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

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

162

135

163instance ToParamSchema Char where

136instance ToParamSchema Char where

164 toParamSchema _ = mempty

137 toParamSchema _ = mempty

165− & type_ ?~ SwaggerString

138+ & type_ .~ SwaggerString

166 & maxLength ?~ 1

139 & maxLength ?~ 1

167 & minLength ?~ 1

140 & minLength ?~ 1

168

141

169instance ToParamSchema Scientific where

142instance ToParamSchema Scientific where

170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber

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

176

144

177instance ToParamSchema Double where

145instance ToParamSchema Double where

178 toParamSchema _ = mempty

146 toParamSchema _ = mempty

179− & type_ ?~ SwaggerNumber

147+ & type_ .~ SwaggerNumber

180 & format ?~ "double"

148 & format ?~ "double"

181

149

182instance ToParamSchema Float where

150instance ToParamSchema Float where

183 toParamSchema _ = mempty

151 toParamSchema _ = mempty

184− & type_ ?~ SwaggerNumber

152+ & type_ .~ SwaggerNumber

185 & format ?~ "float"

153 & format ?~ "float"

186

154

187timeParamSchema :: String -> ParamSchema t

155timeParamSchema :: String -> ParamSchema t

188timeParamSchema fmt = mempty

156timeParamSchema fmt = mempty

189− & type_ ?~ SwaggerString

157+ & type_ .~ SwaggerString

190 & format ?~ T.pack fmt

158 & format ?~ T.pack fmt

191

159

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

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

193instance ToParamSchema Day where

161instance ToParamSchema Day where

194 toParamSchema _ = timeParamSchema "date"

162 toParamSchema _ = timeParamSchema "date"

195

163

196−-- |

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

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

199−instance ToParamSchema TimeOfDay where

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

201−

202-- |

164-- |

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

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

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

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

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

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

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

219

181

220instance ToParamSchema NominalDiffTime where

182instance ToParamSchema NominalDiffTime where

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

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

222

184

223instance ToParamSchema T.Text where

185instance ToParamSchema T.Text where

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

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

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

226instance ToParamSchema TL.Text where

188instance ToParamSchema TL.Text where

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

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

228

190

229−instance ToParamSchema Version where

230− toParamSchema _ = mempty

231− & type_ ?~ SwaggerString

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

233−

234−instance ToParamSchema SetCookie where

235− toParamSchema _ = mempty

236− & type_ ?~ SwaggerString

237−

238−

239−#if __GLASGOW_HASKELL__ < 800

240−#else

241−type family ToParamSchemaByteStringError bs where

242− ToParamSchemaByteStringError bs = TypeError

243− ( 'Text "Impossible to have an instance " :<>: ShowType (ToParamSchema bs) :<>: Text "."

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

245− :$$: 'Text "Consider using byteParamSchema or binaryParamSchema templates." )

246−

247−instance ToParamSchemaByteStringError BS.ByteString => ToParamSchema BS.ByteString where toParamSchema = error "impossible"

248−instance ToParamSchemaByteStringError BSL.ByteString => ToParamSchema BSL.ByteString where toParamSchema = error "impossible"

249−#endif

250−

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

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

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

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

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

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

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

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

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

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

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

258

198

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

260−

261instance ToParamSchema a => ToParamSchema [a] where

199instance ToParamSchema a => ToParamSchema [a] where

262 toParamSchema _ = mempty

200 toParamSchema _ = mempty

263− & type_ ?~ SwaggerArray

201+ & type_ .~ SwaggerArray

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

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

265

203

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

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

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

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

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

281instance ToParamSchema () where

219instance ToParamSchema () where

282 toParamSchema _ = mempty

220 toParamSchema _ = mempty

283− & type_ ?~ SwaggerString

221+ & type_ .~ SwaggerString

284 & enum_ ?~ ["_"]

222 & enum_ ?~ ["_"]

285

223

286−instance ToParamSchema UUID where

287− toParamSchema _ = mempty

288− & type_ ?~ SwaggerString

289− & format ?~ "uuid"

290−

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

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

292--

225--

293-- >>> :set -XDeriveGeneric

226-- >>> :set -XDeriveGeneric

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

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

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

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

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

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

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

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

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

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

299

232

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

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

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

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

302

235

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

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

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

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

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

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

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

317

250

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

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

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

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

320

253

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

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

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

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

323

256

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

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

325 genumParamSchema opts _ s = s

258 genumParamSchema opts _ s = s

326− & type_ ?~ SwaggerString

259+ & type_ .~ SwaggerString

327 & enum_ %~ addEnumValue tag

260 & enum_ %~ addEnumValue tag

328 where

261 where

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

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

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

333

266

334data Proxy3 a b c = Proxy3

267data Proxy3 a b c = Proxy3

335

268

336−-- $setup

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

src/Data/Swagger/Internal/Schema.hs+85−256

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE DefaultSignatures #-}

2{-# LANGUAGE DefaultSignatures #-}

4{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

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

14{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

16{-# LANGUAGE TypeSynonymInstances #-}

15{-# LANGUAGE TypeSynonymInstances #-}

17−{-# LANGUAGE UndecidableInstances #-}

18−#if __GLASGOW_HASKELL__ >= 800

19−-- Few generics related redundant constraints

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

21−-- For TypeErrors

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

23−#endif

24#include "overlapping-compat.h"

16#include "overlapping-compat.h"

25module Data.Swagger.Internal.Schema where

17module Data.Swagger.Internal.Schema where

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

30import Control.Lens

22import Control.Lens

31import Data.Data.Lens (template)

23import Data.Data.Lens (template)

25+import Control.Applicative

33import Control.Monad

26import Control.Monad

34import Control.Monad.Writer

27import Control.Monad.Writer

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

28+import Data.Aeson

29+import qualified Data.Aeson.Types as Aeson

36import Data.Char

30import Data.Char

37import Data.Data (Data)

31import Data.Data (Data)

38import Data.Foldable (traverse_)

32import Data.Foldable (traverse_)

33+import Data.Function (on)

39import Data.HashMap.Strict (HashMap)

34import Data.HashMap.Strict (HashMap)

40import qualified Data.HashMap.Strict as HashMap

35import qualified Data.HashMap.Strict as HashMap

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

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

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

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

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

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

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

44import Data.Int

40import Data.Int

45import Data.IntSet (IntSet)

41import Data.IntSet (IntSet)

46import Data.IntMap (IntMap)

42import Data.IntMap (IntMap)

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

48import Data.Map (Map)

43import Data.Map (Map)

49import Data.Proxy

44import Data.Proxy

50import Data.Scientific (Scientific)

45import Data.Scientific (Scientific)

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

52import Data.Set (Set)

46import Data.Set (Set)

53import qualified Data.Text as T

47import qualified Data.Text as T

54import qualified Data.Text.Lazy as TL

48import qualified Data.Text.Lazy as TL

@@ -57,25 +51,17 @@ import qualified Data.Vector as V

57import qualified Data.Vector.Primitive as VP

51import qualified Data.Vector.Primitive as VP

58import qualified Data.Vector.Storable as VS

52import qualified Data.Vector.Storable as VS

59import qualified Data.Vector.Unboxed as VU

53import qualified Data.Vector.Unboxed as VU

60−import Data.Version (Version)

61−import Numeric.Natural.Compat (Natural)

62import Data.Word

54import Data.Word

63import GHC.Generics

55import GHC.Generics

64−import qualified Data.UUID.Types as UUID

66import Data.Swagger.Declare

57import Data.Swagger.Declare

67import Data.Swagger.Internal

58import Data.Swagger.Internal

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

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

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

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

70−import qualified Data.Swagger.Lens as Swagger

71import Data.Swagger.SchemaOptions

61import Data.Swagger.SchemaOptions

72−import Data.Swagger.Internal.TypeShape

74−#if __GLASGOW_HASKELL__ < 800

63+#ifdef __DOCTEST__

75−#else

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

76−import qualified Data.ByteString as BS

77−import qualified Data.ByteString.Lazy as BSL

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

79#endif

65#endif

81unnamed :: Schema -> NamedSchema

67unnamed :: Schema -> NamedSchema

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

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

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

103--

89--

104-- import Control.Lens

90-- import Control.Lens

105−-- import Data.Proxy

106−-- import Data.Swagger

107--

91--

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

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

109--

93--

110-- instance ToSchema Coord where

94-- instance ToSchema Coord where

111−-- declareNamedSchema _ = do

95+-- declareNamedSchema = do

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

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

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

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

114−-- & type_ ?~ SwaggerObject

98+-- & type_ .~ SwaggerObject

115-- & properties .~

99-- & properties .~

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

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

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

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

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

142 -- together with all used definitions.

126 -- together with all used definitions.

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

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

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

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

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

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

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

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

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

148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

131 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

149

132

150−instance ToSchema TimeOfDay where

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

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

153−

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

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

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

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

156declareSchema = fmap _namedSchemaSchema . declareNamedSchema

135declareSchema = fmap _namedSchemaSchema . declareNamedSchema

157

136

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

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

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

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

144-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name

166-- Just "Day"

145-- Just "Day"

167-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)

146-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)

168−-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"

147+-- "{\"format\":\"date\",\"type\":\"string\"}"

169−toNamedSchema :: ToSchema a => Proxy a -> NamedSchema

148+toNamedSchema :: ToSchema a => proxy a -> NamedSchema

170toNamedSchema = undeclare . declareNamedSchema

149toNamedSchema = undeclare . declareNamedSchema

171

150

172-- | Get type's schema name according to its @'ToSchema'@ instance.

151-- | Get type's schema name according to its @'ToSchema'@ instance.

@@ -176,7 +155,7 @@ toNamedSchema = undeclare . declareNamedSchema

176--

155--

177-- >>> schemaName (Proxy :: Proxy UTCTime)

156-- >>> schemaName (Proxy :: Proxy UTCTime)

178-- Just "UTCTime"

157-- Just "UTCTime"

179−schemaName :: ToSchema a => Proxy a -> Maybe T.Text

158+schemaName :: ToSchema a => proxy a -> Maybe T.Text

180schemaName = _namedSchemaName . toNamedSchema

159schemaName = _namedSchemaName . toNamedSchema

181

160

182-- | Convert a type into a schema.

161-- | Convert a type into a schema.

@@ -186,7 +165,7 @@ schemaName = _namedSchemaName . toNamedSchema

186--

165--

187-- >>> encode $ toSchema (Proxy :: Proxy [Day])

166-- >>> encode $ toSchema (Proxy :: Proxy [Day])

188-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"

167-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"

189−toSchema :: ToSchema a => Proxy a -> Schema

168+toSchema :: ToSchema a => proxy a -> Schema

190toSchema = _namedSchemaSchema . toNamedSchema

169toSchema = _namedSchemaSchema . toNamedSchema

191

170

192-- | Convert a type into a referenced schema if possible.

171-- | Convert a type into a referenced schema if possible.

@@ -197,7 +176,7 @@ toSchema = _namedSchemaSchema . toNamedSchema

197--

176--

198-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)

177-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)

199-- "{\"$ref\":\"#/definitions/Day\"}"

178-- "{\"$ref\":\"#/definitions/Day\"}"

200−toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema

179+toSchemaRef :: ToSchema a => proxy a -> Referenced Schema

201toSchemaRef = undeclare . declareSchemaRef

180toSchemaRef = undeclare . declareSchemaRef

202

181

203-- | Convert a type into a referenced schema if possible

182-- | Convert a type into a referenced schema if possible

@@ -207,7 +186,7 @@ toSchemaRef = undeclare . declareSchemaRef

207-- Schema definitions are typically declared for every referenced schema.

186-- Schema definitions are typically declared for every referenced schema.

208-- If @'declareSchemaRef'@ returns a reference, a corresponding schema

187-- If @'declareSchemaRef'@ returns a reference, a corresponding schema

209-- will be declared (regardless of whether it is recusive or not).

188-- will be declared (regardless of whether it is recusive or not).

210−declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)

189+declareSchemaRef :: ToSchema a => proxy a -> Declare (Definitions Schema) (Referenced Schema)

211declareSchemaRef proxy = do

190declareSchemaRef proxy = do

212 case toNamedSchema proxy of

191 case toNamedSchema proxy of

213 NamedSchema (Just name) schema -> do

192 NamedSchema (Just name) schema -> do

@@ -265,11 +244,11 @@ inlineAllSchemas = inlineSchemasWhen (const True)

265-- | Convert a type into a schema without references.

244-- | Convert a type into a schema without references.

266--

245--

267-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])

246-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])

268−-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"

247+-- "{\"items\":{\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"

269--

248--

270-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema

249-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema

271-- when inlining recursive schemas.

250-- when inlining recursive schemas.

272−toInlinedSchema :: ToSchema a => Proxy a -> Schema

251+toInlinedSchema :: ToSchema a => proxy a -> Schema

273toInlinedSchema proxy = inlineAllSchemas defs schema

252toInlinedSchema proxy = inlineAllSchemas defs schema

274 where

253 where

275 (defs, schema) = runDeclare (declareSchema proxy) mempty

254 (defs, schema) = runDeclare (declareSchema proxy) mempty

@@ -298,20 +277,20 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs

298-- | Default schema for binary data (any sequence of octets).

277-- | Default schema for binary data (any sequence of octets).

299binarySchema :: Schema

278binarySchema :: Schema

300binarySchema = mempty

279binarySchema = mempty

301− & type_ ?~ SwaggerString

280+ & type_ .~ SwaggerString

302 & format ?~ "binary"

281 & format ?~ "binary"

303

282

304-- | Default schema for binary data (base64 encoded).

283-- | Default schema for binary data (base64 encoded).

305byteSchema :: Schema

284byteSchema :: Schema

306byteSchema = mempty

285byteSchema = mempty

307− & type_ ?~ SwaggerString

286+ & type_ .~ SwaggerString

308 & format ?~ "byte"

287 & format ?~ "byte"

309

288

310-- | Default schema for password string.

289-- | Default schema for password string.

311-- @"password"@ format is used to hint UIs the input needs to be obscured.

290-- @"password"@ format is used to hint UIs the input needs to be obscured.

312passwordSchema :: Schema

291passwordSchema :: Schema

313passwordSchema = mempty

292passwordSchema = mempty

314− & type_ ?~ SwaggerString

293+ & type_ .~ SwaggerString

315 & format ?~ "password"

294 & format ?~ "password"

316

295

317-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.

296-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.

@@ -337,12 +316,12 @@ sketchSchema = sketch . toJSON

337 sketch js@(Bool _) = go js

316 sketch js@(Bool _) = go js

338 sketch js = go js & example ?~ js

317 sketch js = go js & example ?~ js

339

318

340− go Null = mempty & type_ ?~ SwaggerNull

319+ go Null = mempty & type_ .~ SwaggerNull

341− go (Bool _) = mempty & type_ ?~ SwaggerBoolean

320+ go js@(Bool _) = mempty & type_ .~ SwaggerBoolean

342− go (String _) = mempty & type_ ?~ SwaggerString

321+ go js@(String s) = mempty & type_ .~ SwaggerString

343− go (Number _) = mempty & type_ ?~ SwaggerNumber

322+ go js@(Number n) = mempty & type_ .~ SwaggerNumber

344− go (Array xs) = mempty

323+ go js@(Array xs) = mempty

345− & type_ ?~ SwaggerArray

324+ & type_ .~ SwaggerArray

346 & items ?~ case ischema of

325 & items ?~ case ischema of

347 Just s -> SwaggerItemsObject (Inline s)

326 Just s -> SwaggerItemsObject (Inline s)

348 _ -> SwaggerItemsArray (map Inline ys)

327 _ -> SwaggerItemsArray (map Inline ys)

@@ -351,10 +330,10 @@ sketchSchema = sketch . toJSON

351 allSame = and ((zipWith (==)) ys (tail ys))

330 allSame = and ((zipWith (==)) ys (tail ys))

352

331

353 ischema = case ys of

332 ischema = case ys of

354− (z:_) | allSame -> Just z

333+ (z:zs) | allSame -> Just z

355− _ -> Nothing

334+ _ -> Nothing

356− go (Object o) = mempty

335+ go js@(Object o) = mempty

357− & type_ ?~ SwaggerObject

336+ & type_ .~ SwaggerObject

358 & required .~ HashMap.keys o

337 & required .~ HashMap.keys o

359 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

338 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

360

339

@@ -377,24 +356,24 @@ sketchSchema = sketch . toJSON

377sketchStrictSchema :: ToJSON a => a -> Schema

356sketchStrictSchema :: ToJSON a => a -> Schema

378sketchStrictSchema = go . toJSON

357sketchStrictSchema = go . toJSON

379 where

358 where

380− go Null = mempty & type_ ?~ SwaggerNull

359+ go Null = mempty & type_ .~ SwaggerNull

381 go js@(Bool _) = mempty

360 go js@(Bool _) = mempty

382− & type_ ?~ SwaggerBoolean

361+ & type_ .~ SwaggerBoolean

383 & enum_ ?~ [js]

362 & enum_ ?~ [js]

384 go js@(String s) = mempty

363 go js@(String s) = mempty

385− & type_ ?~ SwaggerString

364+ & type_ .~ SwaggerString

386 & maxLength ?~ fromIntegral (T.length s)

365 & maxLength ?~ fromIntegral (T.length s)

387 & minLength ?~ fromIntegral (T.length s)

366 & minLength ?~ fromIntegral (T.length s)

388 & pattern ?~ s

367 & pattern ?~ s

389 & enum_ ?~ [js]

368 & enum_ ?~ [js]

390 go js@(Number n) = mempty

369 go js@(Number n) = mempty

391− & type_ ?~ SwaggerNumber

370+ & type_ .~ SwaggerNumber

392 & maximum_ ?~ n

371 & maximum_ ?~ n

393 & minimum_ ?~ n

372 & minimum_ ?~ n

394 & multipleOf ?~ n

373 & multipleOf ?~ n

395 & enum_ ?~ [js]

374 & enum_ ?~ [js]

396 go js@(Array xs) = mempty

375 go js@(Array xs) = mempty

397− & type_ ?~ SwaggerArray

376+ & type_ .~ SwaggerArray

398 & maxItems ?~ fromIntegral sz

377 & maxItems ?~ fromIntegral sz

399 & minItems ?~ fromIntegral sz

378 & minItems ?~ fromIntegral sz

400 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))

379 & items ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))

@@ -404,7 +383,7 @@ sketchStrictSchema = go . toJSON

404 sz = length xs

383 sz = length xs

405 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))

384 allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))

406 go js@(Object o) = mempty

385 go js@(Object o) = mempty

407− & type_ ?~ SwaggerObject

386+ & type_ .~ SwaggerObject

408 & required .~ names

387 & required .~ names

409 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

388 & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

410 & maxProperties ?~ fromIntegral (length names)

389 & maxProperties ?~ fromIntegral (length names)

@@ -414,19 +393,18 @@ sketchStrictSchema = go . toJSON

414 names = HashMap.keys o

393 names = HashMap.keys o

415

394

416class GToSchema (f :: * -> *) where

395class GToSchema (f :: * -> *) where

417− gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

396+ gdeclareNamedSchema :: SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

418

397

419instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where

398instance OVERLAPPABLE_ ToSchema a => ToSchema [a] where

420 declareNamedSchema _ = do

399 declareNamedSchema _ = do

421 ref <- declareSchemaRef (Proxy :: Proxy a)

400 ref <- declareSchemaRef (Proxy :: Proxy a)

422 return $ unnamed $ mempty

401 return $ unnamed $ mempty

423− & type_ ?~ SwaggerArray

402+ & type_ .~ SwaggerArray

424 & items ?~ SwaggerItemsObject ref

403 & items ?~ SwaggerItemsObject ref

425

404

426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

405instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

427instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema

406instance ToSchema Bool where declareNamedSchema = plain . paramSchemaToSchema

428instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema

407instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema

429−instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema

430instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema

408instance ToSchema Int where declareNamedSchema = plain . paramSchemaToSchema

431instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema

409instance ToSchema Int8 where declareNamedSchema = plain . paramSchemaToSchema

432instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema

410instance ToSchema Int16 where declareNamedSchema = plain . paramSchemaToSchema

@@ -438,16 +416,11 @@ instance ToSchema Word16 where declareNamedSchema = plain . paramSchemaToSchema

438instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema

416instance ToSchema Word32 where declareNamedSchema = plain . paramSchemaToSchema

439instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema

417instance ToSchema Word64 where declareNamedSchema = plain . paramSchemaToSchema

440

418

441−instance ToSchema Char where

442− declareNamedSchema proxy = plain (paramSchemaToSchema proxy)

419+instance ToSchema Char where declareNamedSchema = plain . paramSchemaToSchema

443− & mapped.Swagger.schema.example ?~ toJSON '?'

444−

445instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema

420instance ToSchema Scientific where declareNamedSchema = plain . paramSchemaToSchema

446instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema

421instance ToSchema Double where declareNamedSchema = plain . paramSchemaToSchema

447instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema

422instance ToSchema Float where declareNamedSchema = plain . paramSchemaToSchema

448

423

449−instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema

450−

451instance ToSchema a => ToSchema (Maybe a) where

424instance ToSchema a => ToSchema (Maybe a) where

452 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

425 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

453

426

@@ -456,11 +429,6 @@ instance (ToSchema a, ToSchema b) => ToSchema (Either a b)

456instance ToSchema () where

429instance ToSchema () where

457 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)

430 declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)

458

431

459−-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.

460−instance ToSchema UUID.UUID where

461− declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p

462− & example ?~ toJSON (UUID.toText UUID.nil)

463−

464instance (ToSchema a, ToSchema b) => ToSchema (a, b)

432instance (ToSchema a, ToSchema b) => ToSchema (a, b)

465instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)

433instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)

466instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)

434instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)

@@ -470,81 +438,46 @@ instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f

470

438

471timeSchema :: T.Text -> Schema

439timeSchema :: T.Text -> Schema

472timeSchema fmt = mempty

440timeSchema fmt = mempty

473− & type_ ?~ SwaggerString

441+ & type_ .~ SwaggerString

474 & format ?~ fmt

442 & format ?~ fmt

475

443

476-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.

444-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.

477instance ToSchema Day where

445instance ToSchema Day where

478− declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"

446+ declareNamedSchema _ = pure $ named "Day" (timeSchema "date")

479− & example ?~ toJSON (fromGregorian 2016 7 22)

480

447

481-- |

448-- |

482-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format

449-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format

483-- Just "yyyy-mm-ddThh:MM:ss"

450-- Just "yyyy-mm-ddThh:MM:ss"

484instance ToSchema LocalTime where

451instance ToSchema LocalTime where

485− declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"

452+ declareNamedSchema _ = pure $ named "LocalTime" (timeSchema "yyyy-mm-ddThh:MM:ss")

486− & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))

487

453

488-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.

454-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.

489instance ToSchema ZonedTime where

455instance ToSchema ZonedTime where

490 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"

456 declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"

491− & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))

492

457

493instance ToSchema NominalDiffTime where

458instance ToSchema NominalDiffTime where

494− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)

459+ declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Integer)

495

460

496-- |

461-- |

497-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format

462-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format

498-- Just "yyyy-mm-ddThh:MM:ssZ"

463-- Just "yyyy-mm-ddThh:MM:ssZ"

499instance ToSchema UTCTime where

464instance ToSchema UTCTime where

500− declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"

465+ declareNamedSchema _ = pure $ named "UTCTime" (timeSchema "yyyy-mm-ddThh:MM:ssZ")

501− & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)

502

466

503instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema

467instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema

504instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema

468instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema

505

469

506−instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema

507−

508−#if __GLASGOW_HASKELL__ < 800

509−#else

510−type family ToSchemaByteStringError bs where

511− ToSchemaByteStringError bs = TypeError

512− ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."

513− :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."

514− :$$: Text "Consider using byteSchema or binarySchema templates." )

515−

516−instance ToSchemaByteStringError BS.ByteString => ToSchema BS.ByteString where declareNamedSchema = error "impossible"

517−instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"

518−#endif

519−

520instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))

470instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))

521

471

522-- | NOTE: This schema does not account for the uniqueness of keys.

472-- | NOTE: This schema does not account for the uniqueness of keys.

523instance ToSchema a => ToSchema (IntMap a) where

473instance ToSchema a => ToSchema (IntMap a) where

524 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])

474 declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])

525

475

526−#if MIN_VERSION_aeson(1,0,0)

527−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where

528− declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of

529− ToJSONKeyText _ _ -> declareObjectMapSchema

530− ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])

531− where

532− declareObjectMapSchema = do

533− schema <- declareSchemaRef (Proxy :: Proxy v)

534− return $ unnamed $ mempty

535− & type_ ?~ SwaggerObject

536− & additionalProperties ?~ AdditionalPropertiesSchema schema

537−

538−instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where

539− declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))

540−

541−#else

542−

543instance ToSchema a => ToSchema (Map String a) where

476instance ToSchema a => ToSchema (Map String a) where

544 declareNamedSchema _ = do

477 declareNamedSchema _ = do

545 schema <- declareSchemaRef (Proxy :: Proxy a)

478 schema <- declareSchemaRef (Proxy :: Proxy a)

546 return $ unnamed $ mempty

479 return $ unnamed $ mempty

547− & type_ ?~ SwaggerObject

480+ & type_ .~ SwaggerObject

548 & additionalProperties ?~ schema

481 & additionalProperties ?~ schema

549

482

550instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

483instance ToSchema a => ToSchema (Map T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

@@ -554,14 +487,6 @@ instance ToSchema a => ToSchema (HashMap String a) where declareNamedSchema _ =

554instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

487instance ToSchema a => ToSchema (HashMap T.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

555instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

488instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map String a))

556

489

557−#endif

558−

559−instance OVERLAPPING_ ToSchema Object where

560− declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty

561− & type_ ?~ SwaggerObject

562− & description ?~ "Arbitrary JSON object."

563− & additionalProperties ?~ AdditionalPropertiesAllowed True

564−

565instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

490instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

566instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

491instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

567instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

492instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

@@ -575,13 +500,6 @@ instance ToSchema a => ToSchema (Set a) where

575

500

576instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))

501instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))

577

502

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−

585instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema

503instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema

586instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

504instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

587

505

@@ -591,141 +509,61 @@ instance ToSchema a => ToSchema (First a) where declareNamedSchema _ = unname

591instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

509instance ToSchema a => ToSchema (Last a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

592instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

510instance ToSchema a => ToSchema (Dual a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

593

511

594−instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

595−

596-- | Default schema for @'Bounded'@, @'Integral'@ types.

512-- | Default schema for @'Bounded'@, @'Integral'@ types.

597--

513--

598-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)

514-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)

599-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"

515-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"

600−toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema

516+toSchemaBoundedIntegral :: forall a proxy. (Bounded a, Integral a) => proxy a -> Schema

601toSchemaBoundedIntegral _ = mempty

517toSchemaBoundedIntegral _ = mempty

602− & type_ ?~ SwaggerInteger

518+ & type_ .~ SwaggerInteger

603 & minimum_ ?~ fromInteger (toInteger (minBound :: a))

519 & minimum_ ?~ fromInteger (toInteger (minBound :: a))

604 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))

520 & maximum_ ?~ fromInteger (toInteger (maxBound :: a))

605

521

606-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.

522-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.

607−genericToNamedSchemaBoundedIntegral :: forall a d f.

523+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

608 ( Bounded a, Integral a

524 ( Bounded a, Integral a

609 , Generic a, Rep a ~ D1 d f, Datatype d)

525 , Generic a, Rep a ~ D1 d f, Datatype d)

610− => SchemaOptions -> Proxy a -> NamedSchema

526+ => SchemaOptions -> proxy a -> NamedSchema

611genericToNamedSchemaBoundedIntegral opts proxy

527genericToNamedSchemaBoundedIntegral opts proxy

612− = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

528+ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (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

668

529

669-- | A configurable generic @'Schema'@ creator.

530-- | A configurable generic @'Schema'@ creator.

670−genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>

671− SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema

531+genericDeclareSchema :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) Schema

672−genericDeclareSchema = genericDeclareSchemaUnrestricted

532+genericDeclareSchema opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchema opts proxy

673

533

674-- | A configurable generic @'NamedSchema'@ creator.

534-- | A configurable generic @'NamedSchema'@ creator.

675-- This function applied to @'defaultSchemaOptions'@

535-- This function applied to @'defaultSchemaOptions'@

676-- is used as the default for @'declareNamedSchema'@

536-- is used as the default for @'declareNamedSchema'@

677-- when the type is an instance of @'Generic'@.

537-- when the type is an instance of @'Generic'@.

678−genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>

679− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema

680−genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

681−

682−-- | A configurable generic @'Schema'@ creator.

683−--

684−-- Unlike 'genericDeclareSchema' also works for mixed sum types.

685−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

686−genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema

687−genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy

688−

689−-- | A configurable generic @'NamedSchema'@ creator.

690−--

691−-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.

692−-- Use with care since some Swagger tools do not support well schemas for mixed sum types.

693−genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>

694− SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema

538+genericDeclareNamedSchema :: forall a proxy. (Generic a, GToSchema (Rep a)) => SchemaOptions -> proxy a -> Declare (Definitions Schema) NamedSchema

695−genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

539+genericDeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

696−

697−-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.

698−genericNameSchema :: forall a d f.

699− (Generic a, Rep a ~ D1 d f, Datatype d)

700− => SchemaOptions -> Proxy a -> Schema -> NamedSchema

701−genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))

702

540

703−gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text

541+gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

704−gdatatypeSchemaName opts _ = case orig of

542+gdatatypeSchemaName opts _ = case name of

705 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)

543 (c:_) | isAlpha c && isUpper c -> Just (T.pack name)

706 _ -> Nothing

544 _ -> Nothing

707 where

545 where

708− orig = datatypeName (Proxy3 :: Proxy3 d f a)

546+ name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))

709− name = datatypeNameModifier opts orig

710

547

711-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.

548-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.

549+paramSchemaToNamedSchema :: forall a d f proxy.

712−paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>

550+ (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)

713− SchemaOptions -> Proxy a -> NamedSchema

551+ => SchemaOptions -> proxy a -> NamedSchema

714−paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)

552+paramSchemaToNamedSchema opts proxy = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) (paramSchemaToSchema proxy)

715

553

716-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.

554-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.

717−paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema

555+paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema

718−paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy

556+paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)

719

557

720nullarySchema :: Schema

558nullarySchema :: Schema

721nullarySchema = mempty

559nullarySchema = mempty

722− & type_ ?~ SwaggerArray

560+ & type_ .~ SwaggerArray

723 & items ?~ SwaggerItemsArray []

561 & items ?~ SwaggerItemsArray []

724

562

725−gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema

563+gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema

726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

564gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

727

565

728−gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema

566+gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema

729gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty

567gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty

730

568

731instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where

569instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where

@@ -745,7 +583,7 @@ instance OVERLAPPING_ Constructor c => GToSchema (C1 c U1) where

745 gdeclareNamedSchema = gdeclareNamedSumSchema

583 gdeclareNamedSchema = gdeclareNamedSumSchema

746

584

747-- | Single field constructor.

585-- | Single field constructor.

748−instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where

586+instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where

749 gdeclareNamedSchema opts _ s

587 gdeclareNamedSchema opts _ s

750 | unwrapUnaryRecords opts = fieldSchema

588 | unwrapUnaryRecords opts = fieldSchema

751 | otherwise =

589 | otherwise =

@@ -759,7 +597,7 @@ instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s

759 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s

597 recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s

760 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s

598 fieldSchema = gdeclareNamedSchema opts (Proxy :: Proxy f) s

761

599

762−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)

600+gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)

763gdeclareSchemaRef opts proxy = do

601gdeclareSchemaRef opts proxy = do

764 case gtoNamedSchema opts proxy of

602 case gtoNamedSchema opts proxy of

765 NamedSchema (Just name) schema -> do

603 NamedSchema (Just name) schema -> do

@@ -778,7 +616,7 @@ gdeclareSchemaRef opts proxy = do

778 return $ Ref (Reference name)

616 return $ Ref (Reference name)

779 _ -> Inline <$> gdeclareSchema opts proxy

617 _ -> Inline <$> gdeclareSchema opts proxy

780

618

781−appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)

619+appendItem :: Referenced Schema -> Maybe (SwaggerItems SwaggerKindSchema) -> Maybe (SwaggerItems SwaggerKindSchema)

782appendItem x Nothing = Just (SwaggerItemsArray [x])

620appendItem x Nothing = Just (SwaggerItemsArray [x])

783appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))

621appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))

784appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

622appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

@@ -790,12 +628,10 @@ withFieldSchema opts _ isRequiredField schema = do

790 return $

628 return $

791 if T.null fname

629 if T.null fname

792 then schema

630 then schema

793− & type_ ?~ SwaggerArray

631+ & type_ .~ SwaggerArray

794 & items %~ appendItem ref

632 & items %~ appendItem ref

795− & maxItems %~ Just . maybe 1 (+1) -- increment maxItems

796− & minItems %~ Just . maybe 1 (+1) -- increment minItems

797 else schema

633 else schema

798− & type_ ?~ SwaggerObject

634+ & type_ .~ SwaggerObject

799 & properties . at fname ?~ ref

635 & properties . at fname ?~ ref

800 & if isRequiredField

636 & if isRequiredField

801 then required %~ (++ [fname])

637 then required %~ (++ [fname])

@@ -817,13 +653,10 @@ instance OVERLAPPING_ ToSchema c => GToSchema (K1 i (Maybe c)) where

817instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where

653instance OVERLAPPABLE_ ToSchema c => GToSchema (K1 i c) where

818 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)

654 gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)

819

655

820−instance ( GSumToSchema f

656+instance (GSumToSchema f, GSumToSchema g) => GToSchema (f :+: g) where

821− , GSumToSchema g

822− ) => GToSchema (f :+: g)

823− where

824 gdeclareNamedSchema = gdeclareNamedSumSchema

657 gdeclareNamedSchema = gdeclareNamedSumSchema

825

658

826−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

659+gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

827gdeclareNamedSumSchema opts proxy s

660gdeclareNamedSumSchema opts proxy s

828 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)

661 | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)

829 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema

662 | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema

@@ -832,29 +665,29 @@ gdeclareNamedSumSchema opts proxy s

832 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)

665 (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)

833

666

834 toStringTag schema = mempty

667 toStringTag schema = mempty

835− & type_ ?~ SwaggerString

668+ & type_ .~ SwaggerString

836 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)

669 & enum_ ?~ map toJSON (schema ^.. properties.ifolded.asIndex)

837

670

838type AllNullary = All

671type AllNullary = All

839

672

840−class GSumToSchema (f :: * -> *) where

673+class GSumToSchema f where

841− gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

674+ gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

842

675

843instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where

676instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where

844 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)

677 gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)

845

678

846−gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>

679+gsumConToSchemaWith :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>

847− Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema

680+ Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema

848gsumConToSchemaWith ref opts _ schema = schema

681gsumConToSchemaWith ref opts _ schema = schema

849− & type_ ?~ SwaggerObject

682+ & type_ .~ SwaggerObject

850 & properties . at tag ?~ ref

683 & properties . at tag ?~ ref

851 & maxProperties ?~ 1

684 & maxProperties ?~ 1

852 & minProperties ?~ 1

685 & minProperties ?~ 1

853 where

686 where

854 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))

687 tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))

855

688

856−gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>

689+gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>

857− SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema

690+ SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema

858gsumConToSchema opts proxy schema = do

691gsumConToSchema opts proxy schema = do

859 ref <- gdeclareSchemaRef opts proxy

692 ref <- gdeclareSchemaRef opts proxy

860 return $ gsumConToSchemaWith ref opts proxy schema

693 return $ gsumConToSchemaWith ref opts proxy schema

@@ -876,7 +709,3 @@ data Proxy2 a b = Proxy2

876

709

877data Proxy3 a b c = Proxy3

710data Proxy3 a b c = Proxy3

878

711

879−-- $setup

880−-- >>> import Data.Swagger

881−-- >>> import Data.Aeson (encode)

882−-- >>> import Data.Aeson.Types (toJSONKeyText)

src/Data/Swagger/Internal/Schema/Validation.hs+78−263

@@ -1,17 +1,15 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveFunctor #-}

1+{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

3+{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE GADTs #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE LambdaCase #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PackageImports #-}

8+{-# LANGUAGE PackageImports #-}

11−{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TemplateHaskell #-}

14−{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE UndecidableInstances #-}

15-- |

13-- |

16-- Module: Data.Swagger.Internal.Schema.Validation

14-- Module: Data.Swagger.Internal.Schema.Validation

@@ -22,34 +20,30 @@

22-- Validate JSON values with Swagger Schema.

20-- Validate JSON values with Swagger Schema.

23module Data.Swagger.Internal.Schema.Validation where

21module Data.Swagger.Internal.Schema.Validation where

25−import Prelude ()

23+import Control.Applicative

26−import Prelude.Compat

24+import Control.Lens

25+import Control.Lens.TH

26+import Control.Monad (when)

28−import Control.Applicative

29−import Control.Lens

30−import Control.Monad (when)

31−

32−import Data.Aeson hiding (Result)

28+import Data.Aeson hiding (Result)

33−import Data.Aeson.Encode.Pretty (encodePretty)

34−import Data.Foldable (for_, sequenceA_,

29+import Data.Foldable (traverse_, for_, sequenceA_)

35− traverse_)

36−import Data.HashMap.Strict (HashMap)

30+import Data.HashMap.Strict (HashMap)

37−import qualified Data.HashMap.Strict as HashMap

31+import qualified Data.HashMap.Strict as HashMap

38−import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

39import qualified "unordered-containers" Data.HashSet as HashSet

32import qualified "unordered-containers" Data.HashSet as HashSet

33+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

34+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

35+import Data.Monoid

40−import Data.Proxy

36+import Data.Proxy

41−import Data.Scientific (Scientific, isInteger)

37+import Data.Scientific (Scientific, isInteger)

42−import Data.Text (Text)

38+import Data.Text (Text)

43−import qualified Data.Text as Text

39+import qualified Data.Text as Text

44−import qualified Data.Text.Lazy as TL

40+import Data.Vector (Vector)

45−import qualified Data.Text.Lazy.Encoding as TL

46−import Data.Vector (Vector)

47−import qualified Data.Vector as Vector

41+import qualified Data.Vector as Vector

48−

42+

49−import Data.Swagger.Declare

43+import Data.Swagger.Declare

50−import Data.Swagger.Internal

44+import Data.Swagger.Internal

51−import Data.Swagger.Internal.Schema

45+import Data.Swagger.Internal.Schema

52−import Data.Swagger.Lens

46+import Data.Swagger.Lens

54-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.

48-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value.

55-- This can be used with QuickCheck to ensure those instances are coherent:

49-- This can be used with QuickCheck to ensure those instances are coherent:

@@ -58,119 +52,21 @@ import Data.Swagger.Lens

58--

52--

59-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.

53-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.

60-- See @'validateToJSONWithPatternChecker'@.

54-- 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.

67validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]

55validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]

68validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

56validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)

70-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.

58-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.

71-- This can be used with QuickCheck to ensure those instances are coherent.

59-- This can be used with QuickCheck to ensure those instances are coherent.

72--

60--

73−-- For validation without patterns see @'validateToJSON'@. See also:

61+-- For validation without patterns see @'validateToJSON'@.

74−-- 'renderValidationErrors'.

75−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]

62+validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>

76−validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

63+ (Pattern -> Text -> Bool) -> a -> [ValidationError]

77− where

78− (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

79−

80−-- | Pretty print validation errors

81−-- together with actual JSON and Swagger Schema

82−-- (using 'encodePretty').

83−--

84−-- >>> import Data.Aeson as Aeson

85−-- >>> import Data.Foldable (traverse_)

86−-- >>> import GHC.Generics

87−-- >>> data Phone = Phone { value :: String } deriving (Generic)

88−-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)

89−-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]

90−-- >>> instance ToSchema Phone

91−-- >>> instance ToSchema Person

92−-- >>> let person = Person { name = "John", phone = Phone "123456" }

93−-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person

94−-- Validation against the schema fails:

95−-- * property "phone" is required, but not found in "{\"name\":\"John\"}"

96−-- <BLANKLINE>

97−-- JSON value:

98−-- {

99−-- "name": "John"

100−-- }

101−-- <BLANKLINE>

102−-- Swagger Schema:

103−-- {

104−-- "required": [

105−-- "name",

106−-- "phone"

107−-- ],

108−-- "type": "object",

109−-- "properties": {

110−-- "phone": {

111−-- "$ref": "#/definitions/Phone"

112−-- },

113−-- "name": {

114−-- "type": "string"

115−-- }

116−-- }

117−-- }

118−-- <BLANKLINE>

119−-- Swagger Description Context:

120−-- {

121−-- "Phone": {

122−-- "required": [

123−-- "value"

124−-- ],

125−-- "type": "object",

126−-- "properties": {

127−-- "value": {

128−-- "type": "string"

129−-- }

130−-- }

131−-- }

132−-- }

133−-- <BLANKLINE>

134−renderValidationErrors

135− :: forall a. (ToJSON a, ToSchema a)

136− => (a -> [ValidationError]) -> a -> Maybe String

137−renderValidationErrors f x =

138− case f x of

139− [] -> Nothing

140− errors -> Just $ unlines

141− [ "Validation against the schema fails:"

142− , unlines (map (" * " ++) errors)

143− , "JSON value:"

144− , ppJSONString (toJSON x)

145− , ""

146− , "Swagger Schema:"

147− , ppJSONString (toJSON schema_)

148− , ""

149− , "Swagger Description Context:"

150− , ppJSONString (toJSON refs_)

151− ]

152− where

153− ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty

154− (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

155−

156−-- | Validate JSON @'Value'@ against Swagger @'Schema'@.

157−--

158−-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []

159−--

160−-- /NOTE:/ @'validateJSON'@ does not perform string pattern validation.

161−-- See @'validateJSONWithPatternChecker'@.

162−validateJSON :: Definitions Schema -> Schema -> Value -> [ValidationError]

163−validateJSON = validateJSONWithPatternChecker (\_pattern _str -> True)

164−

165−-- | Validate JSON @'Value'@ agains Swagger @'ToSchema'@ for a given value and pattern checker.

166−--

167−-- For validation without patterns see @'validateJSON'@.

168−validateJSONWithPatternChecker :: (Pattern -> Text -> Bool) -> Definitions Schema -> Schema -> Value -> [ValidationError]

169−validateJSONWithPatternChecker checker defs sch js =

170− case runValidation (validateWithSchema js) cfg sch of

64+validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of

171 Failed xs -> xs

65 Failed xs -> xs

172 Passed _ -> mempty

66 Passed _ -> mempty

173 where

67 where

68+ (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

69+ js = toJSON x

174 cfg = defaultConfig

70 cfg = defaultConfig

175 { configPatternChecker = checker

71 { configPatternChecker = checker

176 , configDefinitions = defs }

72 , configDefinitions = defs }

@@ -199,7 +95,7 @@ instance Alternative Result where

199instance Monad Result where

95instance Monad Result where

200 return = pure

96 return = pure

201 Passed x >>= f = f x

97 Passed x >>= f = f x

202− Failed xs >>= _ = Failed xs

98+ Failed xs >>= f = Failed xs

203

204-- | Validation configuration.

100-- | Validation configuration.

205data Config = Config

101data Config = Config

@@ -244,7 +140,7 @@ instance Choice Validation where

244

140

245instance Monad (Validation s) where

141instance Monad (Validation s) where

246 return = pure

142 return = pure

247− Validation x >>= f = Validation (\c s -> x c s >>= \y -> runValidation (f y) c s)

143+ Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)

248 (>>) = (*>)

144 (>>) = (*>)

249

145

250withConfig :: (Config -> Validation s a) -> Validation s a

146withConfig :: (Config -> Validation s a) -> Validation s a

@@ -263,17 +159,11 @@ valid = pure ()

263

159

264-- | Validate schema's property given a lens into that property

160-- | Validate schema's property given a lens into that property

265-- and property checker.

161-- and property checker.

266−checkMissing :: Validation s () -> Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

267−checkMissing missing l g = withSchema $ \sch ->

268− case sch ^. l of

269− Nothing -> missing

270− Just x -> g x

271−

272−-- | Validate schema's property given a lens into that property

273−-- and property checker.

274−-- If property is missing in schema, consider it valid.

275check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

162check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

276−check = checkMissing valid

163+check l g = withSchema $ \schema ->

164+ case schema ^. l of

165+ Nothing -> valid

166+ Just x -> g x

277

167

278-- | Validate same value with different schema.

168-- | Validate same value with different schema.

279sub :: t -> Validation t a -> Validation s a

169sub :: t -> Validation t a -> Validation s a

@@ -291,7 +181,7 @@ withRef (Reference ref) f = withConfig $ \cfg ->

291 Just s -> f s

181 Just s -> f s

292

182

293validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

183validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

294−validateWithSchemaRef (Ref ref) js = withRef ref $ \sch -> sub sch (validateWithSchema js)

184+validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)

295validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

185validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

296

186

297-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

187-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

@@ -313,9 +203,9 @@ validateInteger n = do

313 validateNumber n

203 validateNumber n

314

204

315validateNumber :: Scientific -> Validation (ParamSchema t) ()

205validateNumber :: Scientific -> Validation (ParamSchema t) ()

316−validateNumber n = withConfig $ \_cfg -> withSchema $ \sch -> do

206+validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do

317− let exMax = Just True == sch ^. exclusiveMaximum

207+ let exMax = Just True == schema ^. exclusiveMaximum

318− exMin = Just True == sch ^. exclusiveMinimum

208+ exMin = Just True == schema ^. exclusiveMinimum

319

209

320 check maximum_ $ \m ->

210 check maximum_ $ \m ->

321 when (if exMax then (n >= m) else (n > m)) $

211 when (if exMax then (n >= m) else (n > m)) $

@@ -372,8 +262,8 @@ validateArray xs = do

372 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

262 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

373

263

374validateObject :: HashMap Text Value -> Validation Schema ()

264validateObject :: HashMap Text Value -> Validation Schema ()

375−validateObject o = withSchema $ \sch ->

265+validateObject o = withSchema $ \schema ->

376− case sch ^. discriminator of

266+ case schema ^. discriminator of

377 Just pname -> case fromJSON <$> HashMap.lookup pname o of

267 Just pname -> case fromJSON <$> HashMap.lookup pname o of

378 Just (Success ref) -> validateWithSchemaRef ref (Object o)

268 Just (Success ref) -> validateWithSchemaRef ref (Object o)

379 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

269 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

@@ -392,120 +282,45 @@ validateObject o = withSchema $ \sch ->

392 where

282 where

393 size = fromIntegral (HashMap.size o)

283 size = fromIntegral (HashMap.size o)

394

284

395− validateRequired = withSchema $ \sch -> traverse_ validateReq (sch ^. required)

285+ validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)

396− validateReq n =

286+ validateReq name =

397− when (not (HashMap.member n o)) $

287+ when (not (HashMap.member name o)) $

398− invalid ("property " ++ show n ++ " is required, but not found in " ++ show (encode o))

288+ invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))

399

289

400− validateProps = withSchema $ \sch -> do

290+ validateProps = withSchema $ \schema -> do

401 for_ (HashMap.toList o) $ \(k, v) ->

291 for_ (HashMap.toList o) $ \(k, v) ->

402 case v of

292 case v of

403− Null | not (k `elem` (sch ^. required)) -> valid -- null is fine for non-required property

293+ Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property

404 _ ->

294 _ ->

405− case InsOrdHashMap.lookup k (sch ^. properties) of

295+ case InsOrdHashMap.lookup k (schema ^. properties) of

406− Nothing -> checkMissing (unknownProperty k) additionalProperties $ validateAdditional k v

296+ Nothing -> check additionalProperties $ \s -> validateWithSchemaRef s v

407 Just s -> validateWithSchemaRef s v

297 Just s -> validateWithSchemaRef s v

408

298

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−

417validateEnum :: Value -> Validation (ParamSchema t) ()

299validateEnum :: Value -> Validation (ParamSchema t) ()

418validateEnum value = do

300validateEnum value = do

419 check enum_ $ \xs ->

301 check enum_ $ \xs ->

420 when (value `notElem` xs) $

302 when (value `notElem` xs) $

421 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

303 invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)

422

304

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−

470validateSchemaType :: Value -> Validation Schema ()

305validateSchemaType :: Value -> Validation Schema ()

471−validateSchemaType value = withSchema $ \sch ->

306+validateSchemaType value = withSchema $ \schema ->

472− case (sch ^. type_, value) of

307+ case (schema ^. type_, value) of

473− (Just SwaggerNull, Null) -> valid

308+ (SwaggerNull, Null) -> valid

474− (Just SwaggerBoolean, Bool _) -> valid

309+ (SwaggerBoolean, Bool _) -> valid

475− (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

310+ (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

476− (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

311+ (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

477− (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)

312+ (SwaggerString, String s) -> sub_ paramSchema (validateString s)

478− (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

313+ (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

479− (Just SwaggerObject, Object o) -> validateObject o

314+ (SwaggerObject, Object o) -> validateObject o

480− (Nothing, Null) -> valid

481− (Nothing, Bool _) -> valid

482− -- Number by default

483− (Nothing, Number n) -> sub_ paramSchema (validateNumber n)

484− (Nothing, String s) -> sub_ paramSchema (validateString s)

485− (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)

486− (Nothing, Object o) -> validateObject o

487− bad -> invalid $ "expected JSON value of type " ++ showType bad

315+ (t, _) -> invalid $ "expected JSON value of type " ++ show t

488

316

489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

317validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

490−validateParamSchemaType value = withSchema $ \sch ->

318+validateParamSchemaType value = withSchema $ \schema ->

491− case (sch ^. type_, value) of

319+ case (schema ^. type_, value) of

492− (Just SwaggerBoolean, Bool _) -> valid

320+ (SwaggerBoolean, Bool _) -> valid

493− (Just SwaggerInteger, Number n) -> validateInteger n

321+ (SwaggerInteger, Number n) -> validateInteger n

494− (Just SwaggerNumber, Number n) -> validateNumber n

322+ (SwaggerNumber, Number n) -> validateNumber n

495− (Just SwaggerString, String s) -> validateString s

323+ (SwaggerString, String s) -> validateString s

496− (Just SwaggerArray, Array xs) -> validateArray xs

324+ (SwaggerArray, Array xs) -> validateArray xs

497− (Nothing, Bool _) -> valid

498− -- Number by default

499− (Nothing, Number n) -> validateNumber n

500− (Nothing, String s) -> validateString s

501− (Nothing, Array xs) -> validateArray xs

502− bad -> invalid $ "expected JSON value of type " ++ showType bad

325+ (t, _) -> invalid $ "expected JSON value of type " ++ show t

503−

326+

504−showType :: (Maybe (SwaggerType t), Value) -> String

505−showType (Just type_, _) = show type_

506−showType (Nothing, Null) = "SwaggerNull"

507−showType (Nothing, Bool _) = "SwaggerBoolean"

508−showType (Nothing, Number _) = "SwaggerNumber"

509−showType (Nothing, String _) = "SwaggerString"

510−showType (Nothing, Array _) = "SwaggerArray"

511−showType (Nothing, Object _) = "SwaggerObject"

src/Data/Swagger/Internal/TypeShape.hsdeleted−66

@@ -1,66 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE KindSignatures #-}

5−{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE TypeOperators #-}

7−{-# LANGUAGE UndecidableInstances #-}

8−

9−module Data.Swagger.Internal.TypeShape where

10−

11−import Data.Proxy

12−import GHC.Generics

13−import GHC.TypeLits

14−import GHC.Exts (Constraint)

15−

16−-- | Shape of a datatype.

17−data TypeShape

18− = Enumeration -- ^ A simple enumeration.

19− | SumOfProducts -- ^ A product or a sum of non-unit products.

20− | Mixed -- ^ Mixed sum type with both unit and non-unit constructors.

21−

22−-- | A combined shape for a product type.

23−type family ProdCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

24− ProdCombine Mixed b = Mixed -- technically this cannot happen since Haskell types are sums of products

25− ProdCombine a Mixed = Mixed -- technically this cannot happen since Haskell types are sums of products

26− ProdCombine a b = SumOfProducts

27−

28−-- | A combined shape for a sum type.

29−type family SumCombine (a :: TypeShape) (b :: TypeShape) :: TypeShape where

30− SumCombine Enumeration Enumeration = Enumeration

31− SumCombine SumOfProducts SumOfProducts = SumOfProducts

32− SumCombine a b = Mixed

33−

34−type family TypeHasSimpleShape t (f :: Symbol) :: Constraint where

35− TypeHasSimpleShape t f = GenericHasSimpleShape t f (GenericShape (Rep t))

36−

37−type family GenericHasSimpleShape t (f :: Symbol) (s :: TypeShape) :: Constraint where

38− GenericHasSimpleShape t f Enumeration = ()

39− GenericHasSimpleShape t f SumOfProducts = ()

40−#if __GLASGOW_HASKELL__ < 800

41− GenericHasSimpleShape t f Mixed = CannotDeriveSchemaForMixedSumType t

42−

43−class CannotDeriveSchemaForMixedSumType t where

44−#else

45− GenericHasSimpleShape t f Mixed =

46− TypeError

47− ( Text "Cannot derive Generic-based Swagger Schema for " :<>: ShowType t

48− :$$: ShowType t :<>: Text " is a mixed sum type (has both unit and non-unit constructors)."

49− :$$: Text "Swagger does not have a good representation for these types."

50− :$$: Text "Use " :<>: Text f :<>: Text " if you want to derive schema"

51− :$$: Text "that matches aeson's Generic-based toJSON,"

52− :$$: Text "but that's not supported by some Swagger tools."

53− )

54−#endif

55−

56−-- | Infer a 'TypeShape' for a generic representation of a type.

57−type family GenericShape (g :: * -> *) :: TypeShape

58−

59−type instance GenericShape (f :*: g) = ProdCombine (GenericShape f) (GenericShape g)

60−type instance GenericShape (f :+: g) = SumCombine (GenericShape f) (GenericShape g)

61−type instance GenericShape (D1 d f) = GenericShape f

62−type instance GenericShape (C1 c U1) = Enumeration

63−type instance GenericShape (C1 c (S1 s f)) = SumOfProducts

64−type instance GenericShape (C1 c (f :*: g)) = SumOfProducts

65−

66−

src/Data/Swagger/Internal/Utils.hs+4

@@ -9,6 +9,8 @@ module Data.Swagger.Internal.Utils where

9import Prelude ()

10import Prelude.Compat

12+import Control.Arrow (first)

13+import Control.Applicative

12import Control.Lens ((&), (%~))

14import Control.Lens ((&), (%~))

13import Control.Lens.TH

15import Control.Lens.TH

14import Data.Aeson

16import Data.Aeson

@@ -21,10 +23,12 @@ import qualified Data.HashMap.Strict as HashMap

21import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

23import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

22import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

24import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

23import Data.Map (Map)

25import Data.Map (Map)

26+import Data.Monoid

24import Data.Set (Set)

27import Data.Set (Set)

25import Data.Text (Text)

28import Data.Text (Text)

26import GHC.Generics

29import GHC.Generics

27import Language.Haskell.TH (mkName)

30import Language.Haskell.TH (mkName)

31+import Text.Read (readMaybe)

29swaggerFieldRules :: LensRules

33swaggerFieldRules :: LensRules

30swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer

34swaggerFieldRules = defaultFieldRules & lensField %~ swaggerFieldNamer

src/Data/Swagger/Lens.hs+9−19

@@ -60,23 +60,19 @@ makePrisms ''Referenced

61-- ** 'SwaggerItems' prisms

63−_SwaggerItemsArray :: Review (SwaggerItems 'SwaggerKindSchema) [Referenced Schema]

63+_SwaggerItemsArray :: Review (SwaggerItems SwaggerKindSchema) [Referenced Schema]

64_SwaggerItemsArray

65− = unto (\x -> SwaggerItemsArray x)

65+ = prism (\x -> SwaggerItemsArray x) $ \x -> case x of

66−{- \x -> case x of

67 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

66 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

68 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

67 SwaggerItemsObject o -> Left (SwaggerItemsObject o)

69 SwaggerItemsArray a -> Right a

68 SwaggerItemsArray a -> Right a

70−-}

72−_SwaggerItemsObject :: Review (SwaggerItems 'SwaggerKindSchema) (Referenced Schema)

70+_SwaggerItemsObject :: Review (SwaggerItems SwaggerKindSchema) (Referenced Schema)

73_SwaggerItemsObject

71_SwaggerItemsObject

74− = unto (\x -> SwaggerItemsObject x)

72+ = prism (\x -> SwaggerItemsObject x) $ \x -> case x of

75−{- \x -> case x of

76 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

73 SwaggerItemsPrimitive c p -> Left (SwaggerItemsPrimitive c p)

77 SwaggerItemsObject o -> Right o

74 SwaggerItemsObject o -> Right o

78 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

75 SwaggerItemsArray a -> Left (SwaggerItemsArray a)

79−-}

81_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

77_SwaggerItemsPrimitive :: forall t p f. (Profunctor p, Bifunctor p, Functor f) => Optic' p f (SwaggerItems t) (Maybe (CollectionFormat t), ParamSchema t)

82_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

78_SwaggerItemsPrimitive = unto (\(c, p) -> SwaggerItemsPrimitive c p)

@@ -96,19 +92,13 @@ instance At Responses where at n = responses . at n

96instance Ixed Operation where ix n = responses . ix n

92instance Ixed Operation where ix n = responses . ix n

97instance At Operation where at n = responses . at n

93instance 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−

105−instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

95+instance HasParamSchema NamedSchema (ParamSchema SwaggerKindSchema) where paramSchema = schema.paramSchema

106

107-- HasType instances

97-- HasType instances

108−instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_

98+instance HasType Header (SwaggerType (SwaggerKindNormal Header)) where type_ = paramSchema.type_

109−instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

99+instance HasType Schema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_

110−instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

100+instance HasType NamedSchema (SwaggerType SwaggerKindSchema) where type_ = paramSchema.type_

111−instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_

101+instance HasType ParamOtherSchema (SwaggerType SwaggerKindParamOtherSchema) where type_ = paramSchema.type_

112

102

113-- HasDefault instances

103-- HasDefault instances

114instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

104instance HasDefault Header (Maybe Value) where default_ = paramSchema.default_

src/Data/Swagger/Operation.hs+14−12

@@ -30,23 +30,24 @@ module Data.Swagger.Operation (

30 declareResponse,

31) where

33−import Prelude ()

33+import Control.Applicative

34−import Prelude.Compat

34+import Control.Arrow

35−

36import Control.Lens

35import Control.Lens

37import Data.Data.Lens

36import Data.Data.Lens

37+import qualified Data.HashMap.Strict as HashMap

38−import Data.List.Compat

38+import Data.List

39import Data.Maybe (mapMaybe)

40−import Data.Proxy

40+import Data.Monoid

41import qualified Data.Set as Set

42+import Data.Traversable

43import Data.Swagger.Declare

44import Data.Swagger.Declare

44import Data.Swagger.Internal

45import Data.Swagger.Internal

45import Data.Swagger.Lens

46import Data.Swagger.Lens

46import Data.Swagger.Schema

47import Data.Swagger.Schema

49+import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

48import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

50import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

49−import qualified Data.HashSet.InsOrd as InsOrdHS

51-- $setup

52-- $setup

52-- >>> import Data.Aeson

53-- >>> import Data.Aeson

@@ -112,15 +113,15 @@ applyTags = applyTagsFor allOperations

112-- list of tags.

113-- list of tags.

113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

114applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger

114applyTagsFor ops ts swag = swag

115applyTagsFor ops ts swag = swag

115− & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))

116+ & ops . tags %~ (<> Set.fromList (map _tagName ts))

116− & tags %~ (<> InsOrdHS.fromList ts)

117+ & tags %~ (<> Set.fromList ts)

117

118

118-- | Construct a response with @'Schema'@ while declaring all

119-- | Construct a response with @'Schema'@ while declaring all

119-- necessary schema definitions.

120-- necessary schema definitions.

120--

121--

121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

122-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

122−-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

123+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

123−declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response

124+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

124declareResponse proxy = do

125declareResponse proxy = do

125 s <- declareSchemaRef proxy

126 s <- declareSchemaRef proxy

126 return (mempty & schema ?~ s)

127 return (mempty & schema ?~ s)

@@ -139,7 +140,7 @@ declareResponse proxy = do

139-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

140-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]

140-- >>> let res = declareResponse (Proxy :: Proxy Day)

141-- >>> let res = declareResponse (Proxy :: Proxy Day)

141-- >>> encode $ api & setResponse 200 res

142-- >>> encode $ api & setResponse 200 res

142−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"

143+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}}}"

143--

144--

144-- See also @'setResponseWith'@.

145-- See also @'setResponseWith'@.

145setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

146setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger

@@ -186,8 +187,9 @@ setResponseForWith ops f code dres swag = swag

186 where

187 where

187 (defs, new) = runDeclare dres mempty

188 (defs, new) = runDeclare dres mempty

188

189

189− combine (Just (Ref (Reference n))) = case swag ^. responses.at n of

190+ combine (Just (Ref (Reference name))) = case swag ^. responses.at name of

190 Just old -> f old new

191 Just old -> f old new

191 Nothing -> new -- response name can't be dereferenced, replacing with new response

192 Nothing -> new -- response name can't be dereferenced, replacing with new response

192 combine (Just (Inline old)) = f old new

193 combine (Just (Inline old)) = f old new

193 combine Nothing = new

194 combine Nothing = new

195+

src/Data/Swagger/Optics.hsdeleted−597

@@ -1,597 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE OverloadedLabels #-}

5−{-# LANGUAGE TemplateHaskell #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE UndecidableInstances #-}

8−{-# OPTIONS_GHC -fno-warn-orphans #-}

9−-- |

10−-- Module: Data.Swagger.Optics

11−-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>

12−-- Stability: experimental

13−--

14−-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>

15−-- library.

16−--

17−-- >>> import Data.Aeson

18−-- >>> import Optics.Core

19−-- >>> :set -XOverloadedLabels

20−--

21−-- Example from the "Data.Swagger" module using @optics@:

22−--

23−-- >>> :{

24−-- encode $ (mempty :: Swagger)

25−-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]

26−-- & #paths .~

27−-- [ ("/user", mempty & #get ?~ (mempty

28−-- & #produces ?~ MimeList ["application/json"]

29−-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))

30−-- & at 404 ?~ "User info not found")) ]

31−-- :}

32−-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"

33−--

34−-- For convenience optics are defined as /labels/. It means that field accessor

35−-- names can be overloaded for different types. One such common field is

36−-- @#description@. Many components of a Swagger specification can have

37−-- descriptions, and you can use the same name for them:

38−--

39−-- >>> encode $ (mempty :: Response) & #description .~ "No content"

40−-- "{\"description\":\"No content\"}"

41−-- >>> :{

42−-- encode $ (mempty :: Schema)

43−-- & #type ?~ SwaggerBoolean

44−-- & #description ?~ "To be or not to be"

45−-- :}

46−-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"

47−--

48−-- @'ParamSchema'@ is basically the /base schema specification/ and many types

49−-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively

50−-- made fields of the type that has it. For example, you can use @#type@ to

51−-- access @'SwaggerType'@ of @'Header'@ schema without having to use

52−-- @#paramSchema@:

53−--

54−-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber

55−-- "{\"type\":\"number\"}"

56−--

57−-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and

58−-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:

59−--

60−-- >>> :{

61−-- encode $ (mempty :: Operation)

62−-- & at 404 ?~ "Not found"

63−-- :}

64−-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"

65−--

66−module Data.Swagger.Optics () where

67−

68−import Data.Aeson (Value)

69−import Data.Scientific (Scientific)

70−import Data.Swagger.Internal

71−import Data.Text (Text)

72−import Optics.Core

73−import Optics.TH

74−

75−-- Lenses

76−

77−makeFieldLabels ''Swagger

78−makeFieldLabels ''Host

79−makeFieldLabels ''Info

80−makeFieldLabels ''Contact

81−makeFieldLabels ''License

82−makeFieldLabels ''PathItem

83−makeFieldLabels ''Tag

84−makeFieldLabels ''Operation

85−makeFieldLabels ''Param

86−makeFieldLabels ''ParamOtherSchema

87−makeFieldLabels ''Header

88−makeFieldLabels ''Schema

89−makeFieldLabels ''NamedSchema

90−makeFieldLabels ''ParamSchema

91−makeFieldLabels ''Xml

92−makeFieldLabels ''Responses

93−makeFieldLabels ''Response

94−makeFieldLabels ''SecurityScheme

95−makeFieldLabels ''ApiKeyParams

96−makeFieldLabels ''OAuth2Params

97−makeFieldLabels ''ExternalDocs

98−

99−-- Prisms

100−

101−makePrismLabels ''ParamAnySchema

102−makePrismLabels ''SecuritySchemeType

103−makePrismLabels ''Referenced

104−

105−-- SwaggerItems prisms

106−

107−instance

108− ( a ~ [Referenced Schema]

109− , b ~ [Referenced Schema]

110− ) => LabelOptic "_SwaggerItemsArray"

111− A_Review

112− (SwaggerItems 'SwaggerKindSchema)

113− (SwaggerItems 'SwaggerKindSchema)

114− a

115− b where

116− labelOptic = unto (\x -> SwaggerItemsArray x)

117− {-# INLINE labelOptic #-}

118−

119−instance

120− ( a ~ Referenced Schema

121− , b ~ Referenced Schema

122− ) => LabelOptic "_SwaggerItemsObject"

123− A_Review

124− (SwaggerItems 'SwaggerKindSchema)

125− (SwaggerItems 'SwaggerKindSchema)

126− a

127− b where

128− labelOptic = unto (\x -> SwaggerItemsObject x)

129− {-# INLINE labelOptic #-}

130−

131−instance

132− ( a ~ (Maybe (CollectionFormat t), ParamSchema t)

133− , b ~ (Maybe (CollectionFormat t), ParamSchema t)

134− ) => LabelOptic "_SwaggerItemsPrimitive"

135− A_Review

136− (SwaggerItems t)

137− (SwaggerItems t)

138− a

139− b where

140− labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)

141− {-# INLINE labelOptic #-}

142−

143−-- =============================================================

144−-- More helpful instances for easier access to schema properties

145−

146−type instance Index Responses = HttpStatusCode

147−type instance Index Operation = HttpStatusCode

148−

149−type instance IxValue Responses = Referenced Response

150−type instance IxValue Operation = Referenced Response

151−

152−instance Ixed Responses where

153− ix n = #responses % ix n

154− {-# INLINE ix #-}

155−instance At Responses where

156− at n = #responses % at n

157− {-# INLINE at #-}

158−

159−instance Ixed Operation where

160− ix n = #responses % ix n

161− {-# INLINE ix #-}

162−instance At Operation where

163− at n = #responses % at n

164− {-# INLINE at #-}

165−

166−-- #paramSchema

167−

168−instance

169− ( a ~ ParamSchema 'SwaggerKindSchema

170− , b ~ ParamSchema 'SwaggerKindSchema

171− ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where

172− labelOptic = #schema % #paramSchema

173− {-# INLINE labelOptic #-}

174−

175−-- #type

176−

177−instance

178− ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

179− , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

180− ) => LabelOptic "type" A_Lens Header Header a b where

181− labelOptic = #paramSchema % #type

182− {-# INLINE labelOptic #-}

183−

184−instance

185− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

186− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

187− ) => LabelOptic "type" A_Lens Schema Schema a b where

188− labelOptic = #paramSchema % #type

189− {-# INLINE labelOptic #-}

190−

191−instance

192− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

193− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

194− ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where

195− labelOptic = #paramSchema % #type

196− {-# INLINE labelOptic #-}

197−

198−instance

199− ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

200− , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

201− ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where

202− labelOptic = #paramSchema % #type

203− {-# INLINE labelOptic #-}

204−

205−-- #default

206−

207−instance

208− ( a ~ Maybe Value, b ~ Maybe Value

209− ) => LabelOptic "default" A_Lens Header Header a b where

210− labelOptic = #paramSchema % #default

211− {-# INLINE labelOptic #-}

212−

213−instance

214− ( a ~ Maybe Value, b ~ Maybe Value

215− ) => LabelOptic "default" A_Lens Schema Schema a b where

216− labelOptic = #paramSchema % #default

217− {-# INLINE labelOptic #-}

218−

219−instance

220− ( a ~ Maybe Value, b ~ Maybe Value

221− ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where

222− labelOptic = #paramSchema % #default

223− {-# INLINE labelOptic #-}

224−

225−instance

226− ( a ~ Maybe Value, b ~ Maybe Value

227− ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where

228− labelOptic = #paramSchema % #default

229− {-# INLINE labelOptic #-}

230−

231−-- #format

232−

233−instance

234− ( a ~ Maybe Format, b ~ Maybe Format

235− ) => LabelOptic "format" A_Lens Header Header a b where

236− labelOptic = #paramSchema % #format

237− {-# INLINE labelOptic #-}

238−

239−instance

240− ( a ~ Maybe Format, b ~ Maybe Format

241− ) => LabelOptic "format" A_Lens Schema Schema a b where

242− labelOptic = #paramSchema % #format

243− {-# INLINE labelOptic #-}

244−

245−instance

246− ( a ~ Maybe Format, b ~ Maybe Format

247− ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where

248− labelOptic = #paramSchema % #format

249− {-# INLINE labelOptic #-}

250−

251−instance

252− ( a ~ Maybe Format, b ~ Maybe Format

253− ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where

254− labelOptic = #paramSchema % #format

255− {-# INLINE labelOptic #-}

256−

257−-- #items

258−

259−instance

260− ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

261− , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

262− ) => LabelOptic "items" A_Lens Header Header a b where

263− labelOptic = #paramSchema % #items

264− {-# INLINE labelOptic #-}

265−

266−instance

267− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

268− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

269− ) => LabelOptic "items" A_Lens Schema Schema a b where

270− labelOptic = #paramSchema % #items

271− {-# INLINE labelOptic #-}

272−

273−instance

274− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

275− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

276− ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where

277− labelOptic = #paramSchema % #items

278− {-# INLINE labelOptic #-}

279−

280−instance

281− ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

282− , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

283− ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where

284− labelOptic = #paramSchema % #items

285− {-# INLINE labelOptic #-}

286−

287−-- #maximum

288−

289−instance

290− ( a ~ Maybe Scientific, b ~ Maybe Scientific

291− ) => LabelOptic "maximum" A_Lens Header Header a b where

292− labelOptic = #paramSchema % #maximum

293− {-# INLINE labelOptic #-}

294−

295−instance

296− ( a ~ Maybe Scientific, b ~ Maybe Scientific

297− ) => LabelOptic "maximum" A_Lens Schema Schema a b where

298− labelOptic = #paramSchema % #maximum

299− {-# INLINE labelOptic #-}

300−

301−instance

302− ( a ~ Maybe Scientific, b ~ Maybe Scientific

303− ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where

304− labelOptic = #paramSchema % #maximum

305− {-# INLINE labelOptic #-}

306−

307−instance

308− ( a ~ Maybe Scientific, b ~ Maybe Scientific

309− ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

310− labelOptic = #paramSchema % #maximum

311− {-# INLINE labelOptic #-}

312−

313−-- #exclusiveMaximum

314−

315−instance

316− ( a ~ Maybe Bool, b ~ Maybe Bool

317− ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where

318− labelOptic = #paramSchema % #exclusiveMaximum

319− {-# INLINE labelOptic #-}

320−

321−instance

322− ( a ~ Maybe Bool, b ~ Maybe Bool

323− ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where

324− labelOptic = #paramSchema % #exclusiveMaximum

325− {-# INLINE labelOptic #-}

326−

327−instance

328− ( a ~ Maybe Bool, b ~ Maybe Bool

329− ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where

330− labelOptic = #paramSchema % #exclusiveMaximum

331− {-# INLINE labelOptic #-}

332−

333−instance

334− ( a ~ Maybe Bool, b ~ Maybe Bool

335− ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

336− labelOptic = #paramSchema % #exclusiveMaximum

337− {-# INLINE labelOptic #-}

338−

339−-- #minimum

340−

341−instance

342− ( a ~ Maybe Scientific, b ~ Maybe Scientific

343− ) => LabelOptic "minimum" A_Lens Header Header a b where

344− labelOptic = #paramSchema % #minimum

345− {-# INLINE labelOptic #-}

346−

347−instance

348− ( a ~ Maybe Scientific, b ~ Maybe Scientific

349− ) => LabelOptic "minimum" A_Lens Schema Schema a b where

350− labelOptic = #paramSchema % #minimum

351− {-# INLINE labelOptic #-}

352−

353−instance

354− ( a ~ Maybe Scientific, b ~ Maybe Scientific

355− ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where

356− labelOptic = #paramSchema % #minimum

357− {-# INLINE labelOptic #-}

358−

359−instance

360− ( a ~ Maybe Scientific, b ~ Maybe Scientific

361− ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

362− labelOptic = #paramSchema % #minimum

363− {-# INLINE labelOptic #-}

364−

365−-- #exclusiveMinimum

366−

367−instance

368− ( a ~ Maybe Bool, b ~ Maybe Bool

369− ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where

370− labelOptic = #paramSchema % #exclusiveMinimum

371− {-# INLINE labelOptic #-}

372−

373−instance

374− ( a ~ Maybe Bool, b ~ Maybe Bool

375− ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where

376− labelOptic = #paramSchema % #exclusiveMinimum

377− {-# INLINE labelOptic #-}

378−

379−instance

380− ( a ~ Maybe Bool, b ~ Maybe Bool

381− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where

382− labelOptic = #paramSchema % #exclusiveMinimum

383− {-# INLINE labelOptic #-}

384−

385−instance

386− ( a ~ Maybe Bool, b ~ Maybe Bool

387− ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

388− labelOptic = #paramSchema % #exclusiveMinimum

389− {-# INLINE labelOptic #-}

390−

391−-- #maxLength

392−

393−instance

394− ( a ~ Maybe Integer, b ~ Maybe Integer

395− ) => LabelOptic "maxLength" A_Lens Header Header a b where

396− labelOptic = #paramSchema % #maxLength

397− {-# INLINE labelOptic #-}

398−

399−instance

400− ( a ~ Maybe Integer, b ~ Maybe Integer

401− ) => LabelOptic "maxLength" A_Lens Schema Schema a b where

402− labelOptic = #paramSchema % #maxLength

403− {-# INLINE labelOptic #-}

404−

405−instance

406− ( a ~ Maybe Integer, b ~ Maybe Integer

407− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where

408− labelOptic = #paramSchema % #maxLength

409− {-# INLINE labelOptic #-}

410−

411−instance

412− ( a ~ Maybe Integer, b ~ Maybe Integer

413− ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

414− labelOptic = #paramSchema % #maxLength

415− {-# INLINE labelOptic #-}

416−

417−-- #minLength

418−

419−instance

420− ( a ~ Maybe Integer, b ~ Maybe Integer

421− ) => LabelOptic "minLength" A_Lens Header Header a b where

422− labelOptic = #paramSchema % #minLength

423− {-# INLINE labelOptic #-}

424−

425−instance

426− ( a ~ Maybe Integer, b ~ Maybe Integer

427− ) => LabelOptic "minLength" A_Lens Schema Schema a b where

428− labelOptic = #paramSchema % #minLength

429− {-# INLINE labelOptic #-}

430−

431−instance

432− ( a ~ Maybe Integer, b ~ Maybe Integer

433− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where

434− labelOptic = #paramSchema % #minLength

435− {-# INLINE labelOptic #-}

436−

437−instance

438− ( a ~ Maybe Integer, b ~ Maybe Integer

439− ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

440− labelOptic = #paramSchema % #minLength

441− {-# INLINE labelOptic #-}

442−

443−-- #pattern

444−

445−instance

446− ( a ~ Maybe Text, b ~ Maybe Text

447− ) => LabelOptic "pattern" A_Lens Header Header a b where

448− labelOptic = #paramSchema % #pattern

449− {-# INLINE labelOptic #-}

450−

451−instance

452− ( a ~ Maybe Text, b ~ Maybe Text

453− ) => LabelOptic "pattern" A_Lens Schema Schema a b where

454− labelOptic = #paramSchema % #pattern

455− {-# INLINE labelOptic #-}

456−

457−instance

458− ( a ~ Maybe Text, b ~ Maybe Text

459− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where

460− labelOptic = #paramSchema % #pattern

461− {-# INLINE labelOptic #-}

462−

463−instance

464− ( a ~ Maybe Text, b ~ Maybe Text

465− ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where

466− labelOptic = #paramSchema % #pattern

467− {-# INLINE labelOptic #-}

468−

469−-- #maxItems

470−

471−instance

472− ( a ~ Maybe Integer, b ~ Maybe Integer

473− ) => LabelOptic "maxItems" A_Lens Header Header a b where

474− labelOptic = #paramSchema % #maxItems

475− {-# INLINE labelOptic #-}

476−

477−instance

478− ( a ~ Maybe Integer, b ~ Maybe Integer

479− ) => LabelOptic "maxItems" A_Lens Schema Schema a b where

480− labelOptic = #paramSchema % #maxItems

481− {-# INLINE labelOptic #-}

482−

483−instance

484− ( a ~ Maybe Integer, b ~ Maybe Integer

485− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where

486− labelOptic = #paramSchema % #maxItems

487− {-# INLINE labelOptic #-}

488−

489−instance

490− ( a ~ Maybe Integer, b ~ Maybe Integer

491− ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

492− labelOptic = #paramSchema % #maxItems

493− {-# INLINE labelOptic #-}

494−

495−-- #minItems

496−

497−instance

498− ( a ~ Maybe Integer, b ~ Maybe Integer

499− ) => LabelOptic "minItems" A_Lens Header Header a b where

500− labelOptic = #paramSchema % #minItems

501− {-# INLINE labelOptic #-}

502−

503−instance

504− ( a ~ Maybe Integer, b ~ Maybe Integer

505− ) => LabelOptic "minItems" A_Lens Schema Schema a b where

506− labelOptic = #paramSchema % #minItems

507− {-# INLINE labelOptic #-}

508−

509−instance

510− ( a ~ Maybe Integer, b ~ Maybe Integer

511− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where

512− labelOptic = #paramSchema % #minItems

513− {-# INLINE labelOptic #-}

514−

515−instance

516− ( a ~ Maybe Integer, b ~ Maybe Integer

517− ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

518− labelOptic = #paramSchema % #minItems

519− {-# INLINE labelOptic #-}

520−

521−-- #uniqueItems

522−

523−instance

524− ( a ~ Maybe Bool, b ~ Maybe Bool

525− ) => LabelOptic "uniqueItems" A_Lens Header Header a b where

526− labelOptic = #paramSchema % #uniqueItems

527− {-# INLINE labelOptic #-}

528−

529−instance

530− ( a ~ Maybe Bool, b ~ Maybe Bool

531− ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where

532− labelOptic = #paramSchema % #uniqueItems

533− {-# INLINE labelOptic #-}

534−

535−instance

536− ( a ~ Maybe Bool, b ~ Maybe Bool

537− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where

538− labelOptic = #paramSchema % #uniqueItems

539− {-# INLINE labelOptic #-}

540−

541−instance

542− ( a ~ Maybe Bool, b ~ Maybe Bool

543− ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

544− labelOptic = #paramSchema % #uniqueItems

545− {-# INLINE labelOptic #-}

546−

547−-- #enum

548−

549−instance

550− ( a ~ Maybe [Value], b ~ Maybe [Value]

551− ) => LabelOptic "enum" A_Lens Header Header a b where

552− labelOptic = #paramSchema % #enum

553− {-# INLINE labelOptic #-}

554−

555−instance

556− ( a ~ Maybe [Value], b ~ Maybe [Value]

557− ) => LabelOptic "enum" A_Lens Schema Schema a b where

558− labelOptic = #paramSchema % #enum

559− {-# INLINE labelOptic #-}

560−

561−instance

562− ( a ~ Maybe [Value], b ~ Maybe [Value]

563− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where

564− labelOptic = #paramSchema % #enum

565− {-# INLINE labelOptic #-}

566−

567−instance

568− ( a ~ Maybe [Value], b ~ Maybe [Value]

569− ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where

570− labelOptic = #paramSchema % #enum

571− {-# INLINE labelOptic #-}

572−

573−-- #multipleOf

574−

575−instance

576− ( a ~ Maybe Scientific, b ~ Maybe Scientific

577− ) => LabelOptic "multipleOf" A_Lens Header Header a b where

578− labelOptic = #paramSchema % #multipleOf

579− {-# INLINE labelOptic #-}

580−

581−instance

582− ( a ~ Maybe Scientific, b ~ Maybe Scientific

583− ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where

584− labelOptic = #paramSchema % #multipleOf

585− {-# INLINE labelOptic #-}

586−

587−instance

588− ( a ~ Maybe Scientific, b ~ Maybe Scientific

589− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where

590− labelOptic = #paramSchema % #multipleOf

591− {-# INLINE labelOptic #-}

592−

593−instance

594− ( a ~ Maybe Scientific, b ~ Maybe Scientific

595− ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where

596− labelOptic = #paramSchema % #multipleOf

597− {-# INLINE labelOptic #-}

src/Data/Swagger/Schema.hs−15

@@ -17,25 +17,11 @@ module Data.Swagger.Schema (

17 -- * Generic schema encoding

18 genericDeclareNamedSchema,

19 genericDeclareSchema,

20− genericDeclareNamedSchemaNewtype,

21− genericNameSchema,

22−

23− -- ** 'Bounded' 'Integral'

24 genericToNamedSchemaBoundedIntegral,

20 genericToNamedSchemaBoundedIntegral,

25 toSchemaBoundedIntegral,

21 toSchemaBoundedIntegral,

26−

27− -- ** 'Bounded' 'Enum' key mappings

28− declareSchemaBoundedEnumKeyMapping,

29− toSchemaBoundedEnumKeyMapping,

30−

31− -- ** Reusing 'ToParamSchema'

32 paramSchemaToNamedSchema,

22 paramSchemaToNamedSchema,

33 paramSchemaToSchema,

23 paramSchemaToSchema,

35− -- ** Unrestricted versions

36− genericDeclareNamedSchemaUnrestricted,

37− genericDeclareSchemaUnrestricted,

38−

39 -- * Schema templates

25 -- * Schema templates

40 passwordSchema,

26 passwordSchema,

41 binarySchema,

27 binarySchema,

@@ -54,7 +40,6 @@ module Data.Swagger.Schema (

54 -- * Generic encoding configuration

40 -- * Generic encoding configuration

55 SchemaOptions(..),

41 SchemaOptions(..),

56 defaultSchemaOptions,

42 defaultSchemaOptions,

57− fromAesonOptions,

58) where

43) where

60import Data.Swagger.Internal.Schema

45import Data.Swagger.Internal.Schema

src/Data/Swagger/Schema/Generator.hsdeleted−114

@@ -1,114 +0,0 @@

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE OverloadedLists #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Data.Swagger.Schema.Generator where

6−

7−import Prelude ()

8−import Prelude.Compat

9−

10−import Control.Lens.Operators

11−import Control.Monad (filterM)

12−import Data.Aeson

13−import Data.Aeson.Types

14−import qualified Data.HashMap.Strict.InsOrd as M

15−import Data.Maybe

16−import Data.Maybe

17−import Data.Proxy

18−import Data.Scientific

19−import qualified Data.Set as S

20−import Data.Swagger

21−import Data.Swagger.Declare

22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)

23−import qualified Data.Text as T

24−import qualified Data.Vector as V

25−import Test.QuickCheck (arbitrary)

26−import Test.QuickCheck.Gen

27−import Test.QuickCheck.Property

28−

29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30−-- and cannot be inferred.

31−schemaGen :: Definitions Schema -> Schema -> Gen Value

32−schemaGen _ schema

33− | Just cases <- schema ^. paramSchema . enum_ = elements cases

34−schemaGen defns schema =

35− case schema ^. type_ of

36− Nothing ->

37− case inferSchemaTypes schema of

38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

39− -- Gen is not MonadFail

40− _ -> error "unable to infer schema type"

41− Just SwaggerBoolean -> Bool <$> elements [True, False]

42− Just SwaggerNull -> pure Null

43− Just SwaggerNumber

44− | Just min <- schema ^. minimum_

45− , Just max <- schema ^. maximum_ ->

46− Number . fromFloatDigits <$>

47− choose (toRealFloat min, toRealFloat max :: Double)

48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

49− Just SwaggerInteger

50− | Just min <- schema ^. minimum_

51− , Just max <- schema ^. maximum_ ->

52− Number . fromInteger <$>

53− choose (truncate min, truncate max)

54− | otherwise -> Number . fromInteger <$> arbitrary

55− Just SwaggerArray

56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

57− | Just items <- schema ^. items ->

58− case items of

59− SwaggerItemsObject ref -> do

60− size <- getSize

61− let itemSchema = dereference defns ref

62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems

63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems

64− arrayLength <- choose (minLength', max minLength' maxLength')

65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema

66− return . Array $ V.fromList generatedArray

67− SwaggerItemsArray refs ->

68− let itemGens = schemaGen defns . dereference defns <$> refs

69− in fmap (Array . V.fromList) $ sequence itemGens

70− Just SwaggerString -> do

71− size <- getSize

72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

74− length <- choose (minLength', max minLength' maxLength')

75− str <- vectorOf length arbitrary

76− return . String $ T.pack str

77− Just SwaggerObject -> do

78− size <- getSize

79− let props = dereference defns <$> schema ^. properties

80− reqKeys = S.fromList $ schema ^. required

81− allKeys = S.fromList . M.keys $ schema ^. properties

82− optionalKeys = allKeys S.\\ reqKeys

83− minProps' = fromMaybe (length reqKeys) $

84− fromInteger <$> schema ^. minProperties

85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties

86− shuffledOptional <- shuffle $ S.toList optionalKeys

87− numProps <- choose (minProps', max minProps' maxProps')

88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional

89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props

90− let gens = schemaGen defns <$> presentProps

91− additionalGens <- case schema ^. additionalProperties of

92− Just (AdditionalPropertiesSchema addlSchema) -> do

93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary

94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

95− _ -> return []

96− x <- sequence $ gens <> additionalGens

97− return . Object $ M.toHashMap x

98− where

99− dereference :: Definitions a -> Referenced a -> a

100− dereference _ (Inline a) = a

101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

102−

103−genValue :: (ToSchema a) => Proxy a -> Gen Value

104−genValue p =

105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty

106− in schemaGen defs schema

107−

108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property

109−validateFromJSON p = forAll (genValue p) $

110− \val -> case parseEither parseJSON val of

111− Right (_ :: a) -> succeeded

112− Left err -> failed

113− { reason = err

114− }

src/Data/Swagger/Schema/Validation.hs+1−10

@@ -15,18 +15,9 @@ module Data.Swagger.Schema.Validation (

15 -- $maybe

17 -- * JSON validation

18−

19− ValidationError,

20−

21− -- ** Using 'ToJSON' and 'ToSchema'

22− validatePrettyToJSON,

23 validateToJSON,

18 validateToJSON,

24 validateToJSONWithPatternChecker,

19 validateToJSONWithPatternChecker,

25− renderValidationErrors,

20+ ValidationError,

26−

27− -- ** Using 'Value' and 'Schema'

28− validateJSON,

29− validateJSONWithPatternChecker,

30) where

21) where

32import Data.Swagger.Internal.Schema.Validation

23import Data.Swagger.Internal.Schema.Validation

src/Data/Swagger/SchemaOptions.hs−29

@@ -1,4 +1,3 @@

1−{-# LANGUAGE RecordWildCards #-}

2-- |

1-- |

3-- Module: Data.Swagger.SchemaOptions

2-- Module: Data.Swagger.SchemaOptions

4-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

3-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>

@@ -7,8 +6,6 @@

7-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.

6-- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.

8module Data.Swagger.SchemaOptions where

7module Data.Swagger.SchemaOptions where

10−import qualified Data.Aeson.Types as Aeson

11−

12-- | Options that specify how to encode your type to Swagger schema.

9-- | Options that specify how to encode your type to Swagger schema.

13data SchemaOptions = SchemaOptions

10data SchemaOptions = SchemaOptions

14 { -- | Function applied to field labels. Handy for removing common record prefixes for example.

11 { -- | Function applied to field labels. Handy for removing common record prefixes for example.

@@ -44,29 +41,3 @@ defaultSchemaOptions = SchemaOptions

44 , unwrapUnaryRecords = False

41 , unwrapUnaryRecords = False

45 }

42 }

47−-- | Convert 'Aeson.Options' to 'SchemaOptions'.

48−--

49−-- Specifically the following fields get copied:

50−--

51−-- * 'fieldLabelModifier'

52−-- * 'constructorTagModifier'

53−-- * 'allNullaryToStringTag'

54−-- * 'unwrapUnaryRecords'

55−--

56−-- Note that these fields have no effect on `SchemaOptions`:

57−--

58−-- * 'Aeson.omitNothingFields'

59−-- * 'Aeson.sumEncoding'

60−-- * 'Aeson.tagSingleConstructors'

61−--

62−-- The rest is defined as in 'defaultSchemaOptions'.

63−--

64−-- @since 2.2.1

65−--

66−fromAesonOptions :: Aeson.Options -> SchemaOptions

67−fromAesonOptions opts = defaultSchemaOptions

68− { fieldLabelModifier = Aeson.fieldLabelModifier opts

69− , constructorTagModifier = Aeson.constructorTagModifier opts

70− , allNullaryToStringTag = Aeson.allNullaryToStringTag opts

71− , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts

72− }

stack-lts-2.yamlnew file+5

@@ -0,0 +1,5 @@

1+flags: {}

2+packages:

3+- '.'

4+extra-deps: []

5+resolver: lts-2.22

stack.yaml+4−6

@@ -1,9 +1,7 @@

1−resolver: lts-14.3

1+flags: {}

2packages:

3- '.'

4extra-deps:

5−- optics-core-0.2

5+- aeson-0.11.1.0

6−- optics-th-0.2

7−- optics-extra-0.2

8−- indexed-profunctors-0.1

9−- insert-ordered-containers-0.2.3

6+- insert-ordered-containers-0.1.0.1

7+resolver: nightly-2016-03-04

swagger2.cabal+45−97

@@ -1,15 +1,7 @@

1−cabal-version: >=1.10

2name: swagger2

1name: swagger2

3−version: 2.5

2+version: 2.0.2

4−

5synopsis: Swagger 2.0 data model

3synopsis: Swagger 2.0 data model

6−category: Web, Swagger

7−description:

4+description: Please see README.md

8− This library is intended to be used for decoding and encoding Swagger 2.0 API

9− specifications as well as manipulating them.

10− .

11− The original Swagger 2.0 specification is available at http://swagger.io/specification/.

12−

13homepage: https://github.com/GetShopTV/swagger2

5homepage: https://github.com/GetShopTV/swagger2

14bug-reports: https://github.com/GetShopTV/swagger2/issues

6bug-reports: https://github.com/GetShopTV/swagger2/issues

15license: BSD3

7license: BSD3

@@ -17,22 +9,15 @@ license-file: LICENSE

17author: Nickolay Kudasov

9author: Nickolay Kudasov

18maintainer: nickolay@getshoptv.com

10maintainer: nickolay@getshoptv.com

12+category: Web

20−build-type: Custom

13+build-type: Simple

21extra-source-files:

14extra-source-files:

22 README.md

15 README.md

23 , CHANGELOG.md

16 , CHANGELOG.md

24 , examples/*.hs

17 , examples/*.hs

25 , include/overlapping-compat.h

18 , include/overlapping-compat.h

19+cabal-version: >=1.10

26−tested-with:

20+tested-with: GHC==7.8.4, GHC==7.10.3

27− GHC ==8.0.2

28− || ==8.2.2

29− || ==8.4.4

30− || ==8.6.5

31− || ==8.8.1

32−

33−custom-setup

34− setup-depends:

35− base, Cabal, cabal-doctest >=1.0.6 && <1.1

37library

22library

38 hs-source-dirs: src

23 hs-source-dirs: src

@@ -42,10 +27,8 @@ library

42 Data.Swagger.Declare

27 Data.Swagger.Declare

43 Data.Swagger.Lens

28 Data.Swagger.Lens

44 Data.Swagger.Operation

29 Data.Swagger.Operation

45− Data.Swagger.Optics

46 Data.Swagger.ParamSchema

30 Data.Swagger.ParamSchema

47 Data.Swagger.Schema

31 Data.Swagger.Schema

48− Data.Swagger.Schema.Generator

49 Data.Swagger.Schema.Validation

32 Data.Swagger.Schema.Validation

50 Data.Swagger.SchemaOptions

33 Data.Swagger.SchemaOptions

@@ -56,97 +39,62 @@ library

56 Data.Swagger.Internal.ParamSchema

39 Data.Swagger.Internal.ParamSchema

57 Data.Swagger.Internal.Utils

40 Data.Swagger.Internal.Utils

58 Data.Swagger.Internal.AesonUtils

41 Data.Swagger.Internal.AesonUtils

59− Data.Swagger.Internal.TypeShape

60−

61− -- GHC boot libraries

62− build-depends:

42+ build-depends: base >=4.7 && <4.10

63− base >=4.9 && <4.14

43+ , base-compat >=0.6.0 && <0.10

64− , aeson-pretty >=0.8.7 && <0.9

65− , bytestring >=0.10.4.0 && <0.11

66− , containers >=0.5.5.1 && <0.7

67− , template-haskell >=2.9.0.0 && <2.16

68− , time >=1.4.2 && <1.10

69− , transformers >=0.3.0.0 && <0.6

70−

71− build-depends:

72− mtl >=2.1 && <2.3

73− , text >=1.2.3.0 && <1.3

74−

75− -- other dependencies

76− build-depends:

77− base-compat-batteries >=0.10.4 && <0.12

78− , aeson >=1.4.2.0 && <1.5

44+ , aeson

79− -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

45+ , containers

80− , cookie >=0.4.3 && <0.5

46+ , hashable

81− , generics-sop >=0.3.2.0 && <0.6

47+ , generics-sop >=0.2 && <0.3

82− , hashable >=1.2.7.0 && <1.4

83− , http-media >=0.7.1.2 && <0.9

48+ , http-media

84− , insert-ordered-containers >=0.2.3 && <0.3

49+ , insert-ordered-containers >=0.1.0.0 && <0.2

85− , lens >=4.16.1 && <4.19

50+ , lens

51+ , mtl

86− , network >=2.6.3.5 && <3.2

52+ , network

87− , optics-core >=0.2 && <0.3

88− , optics-th >=0.2 && <0.3

89− , scientific >=0.3.6.2 && <0.4

53+ , scientific

90− , transformers-compat >=0.3 && <0.7

54+ , text

55+ , template-haskell

56+ , time

57+ , transformers

91− , unordered-containers >=0.2.9.0 && <0.3

58+ , unordered-containers

92− , uuid-types >=1.0.3 && <1.1

93− , vector >=0.12.0.1 && <0.13

59+ , vector

94− , QuickCheck >=2.10.1 && <2.14

95−

96 default-language: Haskell2010

60 default-language: Haskell2010

98test-suite spec

62test-suite spec

99 type: exitcode-stdio-1.0

63 type: exitcode-stdio-1.0

100 hs-source-dirs: test

64 hs-source-dirs: test

101 main-is: Spec.hs

65 main-is: Spec.hs

102−

103− -- From library parat

104 -- We need aeson's toEncoding for doctests too

66 -- We need aeson's toEncoding for doctests too

105− build-depends:

67+ build-depends: base

106− base

107− , swagger2

108− , aeson

109− , base-compat-batteries

68+ , base-compat

69+ , aeson >=0.10.0.0

70+ , aeson-qq

110− , bytestring

71+ , bytestring

111− , containers

72+ , containers

112− , hashable

73+ , hashable

74+ , hspec

113− , insert-ordered-containers

75+ , insert-ordered-containers

114− , lens

76+ , HUnit

115− , mtl

77+ , mtl

116− , template-haskell

78+ , QuickCheck

79+ , swagger2

117− , text

80+ , text

118− , time

81+ , time

119− , unordered-containers

82+ , unordered-containers

120− , vector

83+ , vector

121− , QuickCheck

84+ , lens

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−

134 other-modules:

85 other-modules:

135 SpecCommon

86 SpecCommon

136 Data.SwaggerSpec

87 Data.SwaggerSpec

137− Data.Swagger.CommonTestTypes

138 Data.Swagger.ParamSchemaSpec

88 Data.Swagger.ParamSchemaSpec

139 Data.Swagger.SchemaSpec

89 Data.Swagger.SchemaSpec

140 Data.Swagger.Schema.ValidationSpec

90 Data.Swagger.Schema.ValidationSpec

141− Data.Swagger.Schema.GeneratorSpec

142 default-language: Haskell2010

91 default-language: Haskell2010

143

144−test-suite doctests

93+test-suite doctest

145− -- See QuickCheck note in https://github.com/phadej/cabal-doctest#notes

146− build-depends: base, doctest, Glob, QuickCheck

94+ build-depends: base, doctest, Glob

147 default-language: Haskell2010

95 default-language: Haskell2010

148 hs-source-dirs: test

96 hs-source-dirs: test

149− main-is: doctests.hs

97+ main-is: DocTest.hs

150 type: exitcode-stdio-1.0

98 type: exitcode-stdio-1.0

151

152source-repository head

100source-repository head

test/Data/Swagger/CommonTestTypes.hsdeleted−679

@@ -1,679 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE QuasiQuotes #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Data.Swagger.CommonTestTypes where

6−

7−import Prelude ()

8−import Prelude.Compat

9−

10−import Data.Aeson (ToJSON (..), ToJSONKey (..), Value)

11−import Data.Aeson.QQ.Simple

12−import Data.Aeson.Types (toJSONKeyText)

13−import Data.Char

14−import Data.Map (Map)

15−import Data.Proxy

16−import Data.Set (Set)

17−import qualified Data.Text as Text

18−import GHC.Generics

19−

20−import Data.Swagger

21−

22−-- ========================================================================

23−-- Unit type

24−-- ========================================================================

25−

26−data Unit = Unit deriving (Generic)

27−instance ToParamSchema Unit

28−instance ToSchema Unit

29−

30−unitSchemaJSON :: Value

31−unitSchemaJSON = [aesonQQ|

32−{

33− "type": "string",

34− "enum": ["Unit"]

35−}

36−|]

37−

38−-- ========================================================================

39−-- Color (enum)

40−-- ========================================================================

41−data Color

42− = Red

43− | Green

44− | Blue

45− deriving (Generic)

46−instance ToParamSchema Color

47−instance ToSchema Color

48−

49−colorSchemaJSON :: Value

50−colorSchemaJSON = [aesonQQ|

51−{

52− "type": "string",

53− "enum": ["Red", "Green", "Blue"]

54−}

55−|]

56−

57−-- ========================================================================

58−-- Shade (paramSchemaToNamedSchema)

59−-- ========================================================================

60−

61−data Shade = Dim | Bright deriving (Generic)

62−instance ToParamSchema Shade

63−

64−instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions

65−

66−shadeSchemaJSON :: Value

67−shadeSchemaJSON = [aesonQQ|

68−{

69− "type": "string",

70− "enum": ["Dim", "Bright"]

71−}

72−|]

73−

74−-- ========================================================================

75−-- Paint (record with bounded enum property)

76−-- ========================================================================

77−

78−newtype Paint = Paint { color :: Color }

79− deriving (Generic)

80−instance ToSchema Paint

81−

82−paintSchemaJSON :: Value

83−paintSchemaJSON = [aesonQQ|

84−{

85− "type": "object",

86− "properties":

87− {

88− "color":

89− {

90− "$ref": "#/definitions/Color"

91− }

92− },

93− "required": ["color"]

94−}

95−|]

96−

97−paintInlinedSchemaJSON :: Value

98−paintInlinedSchemaJSON = [aesonQQ|

99−{

100− "type": "object",

101− "properties":

102− {

103− "color":

104− {

105− "type": "string",

106− "enum": ["Red", "Green", "Blue"]

107− }

108− },

109− "required": ["color"]

110−}

111−|]

112−

113−-- ========================================================================

114−-- Status (constructorTagModifier)

115−-- ========================================================================

116−

117−data Status

118− = StatusOk

119− | StatusError

120− deriving (Generic)

121−

122−instance ToParamSchema Status where

123− toParamSchema = genericToParamSchema defaultSchemaOptions

124− { constructorTagModifier = map toLower . drop (length "Status") }

125−instance ToSchema Status where

126− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

127− { constructorTagModifier = map toLower . drop (length "Status") }

128−

129−statusSchemaJSON :: Value

130−statusSchemaJSON = [aesonQQ|

131−{

132− "type": "string",

133− "enum": ["ok", "error"]

134−}

135−|]

136−

137−-- ========================================================================

138−-- Email (newtype with unwrapUnaryRecords set to True)

139−-- ========================================================================

140−

141−newtype Email = Email { getEmail :: String }

142− deriving (Generic)

143−instance ToParamSchema Email

144−instance ToSchema Email where

145− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

146− { unwrapUnaryRecords = True }

147−

148−emailSchemaJSON :: Value

149−emailSchemaJSON = [aesonQQ|

150−{

151− "type": "string"

152−}

153−|]

154−

155−-- ========================================================================

156−-- UserId (non-record newtype)

157−-- ========================================================================

158−

159−newtype UserId = UserId Integer

160− deriving (Eq, Ord, Generic)

161−instance ToParamSchema UserId

162−instance ToSchema UserId

163−

164−userIdSchemaJSON :: Value

165−userIdSchemaJSON = [aesonQQ|

166−{

167− "type": "integer"

168−}

169−|]

170−

171−-- ========================================================================

172−-- UserGroup (set newtype)

173−-- ========================================================================

174−

175−newtype UserGroup = UserGroup (Set UserId)

176− deriving (Generic)

177−instance ToSchema UserGroup

178−

179−userGroupSchemaJSON :: Value

180−userGroupSchemaJSON = [aesonQQ|

181−{

182− "type": "array",

183− "items": { "$ref": "#/definitions/UserId" },

184− "uniqueItems": true

185−}

186−|]

187−

188−-- ========================================================================

189−-- Person (simple record with optional fields)

190−-- ========================================================================

191−data Person = Person

192− { name :: String

193− , phone :: Integer

194− , email :: Maybe String

195− } deriving (Generic)

196−

197−instance ToSchema Person

198−

199−personSchemaJSON :: Value

200−personSchemaJSON = [aesonQQ|

201−{

202− "type": "object",

203− "properties":

204− {

205− "name": { "type": "string" },

206− "phone": { "type": "integer" },

207− "email": { "type": "string" }

208− },

209− "required": ["name", "phone"]

210−}

211−|]

212−

213−-- ========================================================================

214−-- Player (record newtype)

215−-- ========================================================================

216−

217−newtype Player = Player

218− { position :: Point

219− } deriving (Generic)

220−instance ToSchema Player

221−

222−playerSchemaJSON :: Value

223−playerSchemaJSON = [aesonQQ|

224−{

225− "type": "object",

226− "properties":

227− {

228− "position":

229− {

230− "$ref": "#/definitions/Point"

231− }

232− },

233− "required": ["position"]

234−}

235−|]

236−

237−newtype Players = Players [Inlined Player]

238− deriving (Generic)

239−instance ToSchema Players

240−

241−playersSchemaJSON :: Value

242−playersSchemaJSON = [aesonQQ|

243−{

244− "type": "array",

245− "items":

246− {

247− "type": "object",

248− "properties":

249− {

250− "position":

251− {

252− "$ref": "#/definitions/Point"

253− }

254− },

255− "required": ["position"]

256− }

257−}

258−|]

259−

260−-- ========================================================================

261−-- Character (sum type with ref and record in alternative)

262−-- ========================================================================

263−

264−data Character

265− = PC Player

266− | NPC { npcName :: String, npcPosition :: Point }

267− deriving (Generic)

268−instance ToSchema Character

269−

270−characterSchemaJSON :: Value

271−characterSchemaJSON = [aesonQQ|

272−{

273− "type": "object",

274− "properties":

275− {

276− "PC": { "$ref": "#/definitions/Player" },

277− "NPC":

278− {

279− "type": "object",

280− "properties":

281− {

282− "npcName": { "type": "string" },

283− "npcPosition": { "$ref": "#/definitions/Point" }

284− },

285− "required": ["npcName", "npcPosition"]

286− }

287− },

288− "maxProperties": 1,

289− "minProperties": 1

290−}

291−|]

292−

293−characterInlinedSchemaJSON :: Value

294−characterInlinedSchemaJSON = [aesonQQ|

295−{

296− "type": "object",

297− "properties":

298− {

299− "PC":

300− {

301− "type": "object",

302− "properties":

303− {

304− "position":

305− {

306− "type": "object",

307− "properties":

308− {

309− "x": { "type": "number", "format": "double" },

310− "y": { "type": "number", "format": "double" }

311− },

312− "required": ["x", "y"]

313− }

314− },

315− "required": ["position"]

316− },

317− "NPC":

318− {

319− "type": "object",

320− "properties":

321− {

322− "npcName": { "type": "string" },

323− "npcPosition":

324− {

325− "type": "object",

326− "properties":

327− {

328− "x": { "type": "number", "format": "double" },

329− "y": { "type": "number", "format": "double" }

330− },

331− "required": ["x", "y"]

332− }

333− },

334− "required": ["npcName", "npcPosition"]

335− }

336− },

337− "maxProperties": 1,

338− "minProperties": 1

339−}

340−|]

341−

342−characterInlinedPlayerSchemaJSON :: Value

343−characterInlinedPlayerSchemaJSON = [aesonQQ|

344−{

345− "type": "object",

346− "properties":

347− {

348− "PC":

349− {

350− "type": "object",

351− "properties":

352− {

353− "position":

354− {

355− "$ref": "#/definitions/Point"

356− }

357− },

358− "required": ["position"]

359− },

360− "NPC":

361− {

362− "type": "object",

363− "properties":

364− {

365− "npcName": { "type": "string" },

366− "npcPosition": { "$ref": "#/definitions/Point" }

367− },

368− "required": ["npcName", "npcPosition"]

369− }

370− },

371− "maxProperties": 1,

372− "minProperties": 1

373−}

374−|]

375−

376−-- ========================================================================

377−-- ISPair (non-record product data type)

378−-- ========================================================================

379−data ISPair = ISPair Integer String

380− deriving (Generic)

381−

382−instance ToSchema ISPair

383−

384−ispairSchemaJSON :: Value

385−ispairSchemaJSON = [aesonQQ|

386−{

387− "type": "array",

388− "items":

389− [

390− { "type": "integer" },

391− { "type": "string" }

392− ],

393− "minItems": 2,

394− "maxItems": 2

395−}

396−|]

397−

398−-- ========================================================================

399−-- Point (record data type with custom fieldLabelModifier)

400−-- ========================================================================

401−

402−data Point = Point

403− { pointX :: Double

404− , pointY :: Double

405− } deriving (Generic)

406−

407−instance ToSchema Point where

408− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

409− { fieldLabelModifier = map toLower . drop (length "point") }

410−

411−pointSchemaJSON :: Value

412−pointSchemaJSON = [aesonQQ|

413−{

414− "type": "object",

415− "properties":

416− {

417− "x": { "type": "number", "format": "double" },

418− "y": { "type": "number", "format": "double" }

419− },

420− "required": ["x", "y"]

421−}

422−|]

423−

424−-- ========================================================================

425−-- Point (record data type with multiple fields)

426−-- ========================================================================

427−

428−data Point5 = Point5

429− { point5X :: Double

430− , point5Y :: Double

431− , point5Z :: Double

432− , point5U :: Double

433− , point5V :: Double -- 5 dimensional!

434− } deriving (Generic)

435−

436−instance ToSchema Point5 where

437− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

438− { fieldLabelModifier = map toLower . drop (length "point5") }

439−

440−point5SchemaJSON :: Value

441−point5SchemaJSON = [aesonQQ|

442−{

443− "type": "object",

444− "properties":

445− {

446− "x": { "type": "number", "format": "double" },

447− "y": { "type": "number", "format": "double" },

448− "z": { "type": "number", "format": "double" },

449− "u": { "type": "number", "format": "double" },

450− "v": { "type": "number", "format": "double" }

451− },

452− "required": ["x", "y", "z", "u", "v"]

453−}

454−|]

455−

456−point5Properties :: [String]

457−point5Properties = ["x", "y", "z", "u", "v"]

458−

459−-- ========================================================================

460−-- MyRoseTree (custom datatypeNameModifier)

461−-- ========================================================================

462−

463−data MyRoseTree = MyRoseTree

464− { root :: String

465− , trees :: [MyRoseTree]

466− } deriving (Generic)

467−

468−instance ToSchema MyRoseTree where

469− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

470− { datatypeNameModifier = drop (length "My") }

471−

472−myRoseTreeSchemaJSON :: Value

473−myRoseTreeSchemaJSON = [aesonQQ|

474−{

475− "type": "object",

476− "properties":

477− {

478− "root": { "type": "string" },

479− "trees":

480− {

481− "type": "array",

482− "items":

483− {

484− "$ref": "#/definitions/RoseTree"

485− }

486− }

487− },

488− "required": ["root", "trees"]

489−}

490−|]

491−

492−data MyRoseTree' = MyRoseTree'

493− { root' :: String

494− , trees' :: [MyRoseTree']

495− } deriving (Generic)

496−

497−instance ToSchema MyRoseTree' where

498− declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

499− { datatypeNameModifier = map toLower }

500−

501−myRoseTreeSchemaJSON' :: Value

502−myRoseTreeSchemaJSON' = [aesonQQ|

503−{

504− "type": "object",

505− "properties":

506− {

507− "root'": { "type": "string" },

508− "trees'":

509− {

510− "type": "array",

511− "items":

512− {

513− "$ref": "#/definitions/myrosetree'"

514− }

515− }

516− },

517− "required": ["root'", "trees'"]

518−}

519−|]

520−

521−-- ========================================================================

522−-- Inlined (newtype for inlining schemas)

523−-- ========================================================================

524−

525−newtype Inlined a = Inlined { getInlined :: a }

526−

527−instance ToSchema a => ToSchema (Inlined a) where

528− declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

529− where

530− unname (NamedSchema _ s) = NamedSchema Nothing s

531−

532−-- ========================================================================

533−-- Light (sum type with unwrapUnaryRecords)

534−-- ========================================================================

535−

536−data Light

537− = NoLight

538− | LightFreq Double

539− | LightColor Color

540− | LightWaveLength { waveLength :: Double }

541− deriving (Generic)

542−

543−instance ToSchema Light where

544− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

545− { unwrapUnaryRecords = True }

546−

547−lightSchemaJSON :: Value

548−lightSchemaJSON = [aesonQQ|

549−{

550− "type": "object",

551− "properties":

552− {

553− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

554− "LightFreq": { "type": "number", "format": "double" },

555− "LightColor": { "$ref": "#/definitions/Color" },

556− "LightWaveLength": { "type": "number", "format": "double" }

557− },

558− "maxProperties": 1,

559− "minProperties": 1

560−}

561−|]

562−

563−lightInlinedSchemaJSON :: Value

564−lightInlinedSchemaJSON = [aesonQQ|

565−{

566− "type": "object",

567− "properties":

568− {

569− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

570− "LightFreq": { "type": "number", "format": "double" },

571− "LightColor":

572− {

573− "type": "string",

574− "enum": ["Red", "Green", "Blue"]

575− },

576− "LightWaveLength": { "type": "number", "format": "double" }

577− },

578− "maxProperties": 1,

579− "minProperties": 1

580−}

581−|]

582−

583−-- ========================================================================

584−-- ResourceId (series of newtypes)

585−-- ========================================================================

586−

587−newtype Id = Id String deriving (Generic)

588−instance ToSchema Id

589−

590−newtype ResourceId = ResourceId Id deriving (Generic)

591−instance ToSchema ResourceId

592−

593−-- ========================================================================

594−-- ButtonImages (bounded enum key mapping)

595−-- ========================================================================

596−

597−data ButtonState = Neutral | Focus | Active | Hover | Disabled

598− deriving (Show, Bounded, Enum, Generic)

599−

600−instance ToJSON ButtonState

601−instance ToSchema ButtonState

602−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show)

603−

604−type ImageUrl = Text.Text

605−

606−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

607− deriving (Generic)

608−

609−instance ToJSON ButtonImages where

610− toJSON = toJSON . getButtonImages

611−

612−instance ToSchema ButtonImages where

613− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

614− declareSchemaBoundedEnumKeyMapping

615−

616−buttonImagesSchemaJSON :: Value

617−buttonImagesSchemaJSON = [aesonQQ|

618−{

619− "type": "object",

620− "properties":

621− {

622− "Neutral": { "type": "string" },

623− "Focus": { "type": "string" },

624− "Active": { "type": "string" },

625− "Hover": { "type": "string" },

626− "Disabled": { "type": "string" }

627− }

628−}

629−|]

630−

631−-- ========================================================================

632−-- SingleMaybeField (single field data with optional field)

633−-- ========================================================================

634−

635−data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String }

636− deriving (Show, Generic)

637−

638−instance ToJSON SingleMaybeField

639−instance ToSchema SingleMaybeField

640−

641−singleMaybeFieldSchemaJSON :: Value

642−singleMaybeFieldSchemaJSON = [aesonQQ|

643−{

644− "type": "object",

645− "properties":

646− {

647− "singleMaybeField": { "type": "string" }

648− }

649−}

650−|]

651−

652−

653−-- ========================================================================

654−-- TimeOfDay

655−-- ========================================================================

656−data TimeOfDay

657− = Int

658− | Pico

659− deriving (Generic)

660−instance ToSchema TimeOfDay

661−instance ToParamSchema TimeOfDay

662−

663−

664−timeOfDaySchemaJSON :: Value

665−timeOfDaySchemaJSON = [aesonQQ|

666−{

667− "example": "12:33:15",

668− "type": "string",

669− "format": "hh:MM:ss"

670−}

671−|]

672−

673−timeOfDayParamSchemaJSON :: Value

674−timeOfDayParamSchemaJSON = [aesonQQ|

675−{

676− "type": "string",

677− "format": "hh:MM:ss"

678−}

679−|]

test/Data/Swagger/ParamSchemaSpec.hs+84−8

@@ -3,11 +3,10 @@

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE QuasiQuotes #-}

6−{-# LANGUAGE OverloadedStrings #-}

7module Data.Swagger.ParamSchemaSpec where

6module Data.Swagger.ParamSchemaSpec where

9import Data.Aeson

8import Data.Aeson

10−import Data.Aeson.QQ.Simple

9+import Data.Aeson.QQ

11import Data.Char

10import Data.Char

12import Data.Proxy

11import Data.Proxy

13import GHC.Generics

12import GHC.Generics

@@ -15,15 +14,11 @@ import GHC.Generics

15import Data.Swagger

14import Data.Swagger

16import Data.Swagger.Internal (SwaggerKind(..))

15import Data.Swagger.Internal (SwaggerKind(..))

18−import Data.Swagger.CommonTestTypes

19import SpecCommon

17import SpecCommon

20import Test.Hspec

18import Test.Hspec

21−import Data.Time.LocalTime

22−

23−import qualified Data.HashMap.Strict as HM

25checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

20checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

26−checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

21+checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema (SwaggerKindNormal Param)) <=> js

28spec :: Spec

23spec :: Spec

29spec = do

24spec = do

@@ -34,7 +29,88 @@ spec = do

34 context "Unary records" $ do

29 context "Unary records" $ do

35 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

30 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

36 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

31 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

39main :: IO ()

33main :: IO ()

40main = hspec spec

34main = hspec spec

35+

36+-- ========================================================================

37+-- Unit type

38+-- ========================================================================

39+

40+data Unit = Unit deriving (Generic)

41+instance ToParamSchema Unit

42+

43+unitSchemaJSON :: Value

44+unitSchemaJSON = [aesonQQ|

45+{

46+ "type": "string",

47+ "enum": ["Unit"]

48+}

49+|]

50+

51+-- ========================================================================

52+-- Color (enum)

53+-- ========================================================================

54+data Color

55+ = Red

56+ | Green

57+ | Blue

58+ deriving (Generic)

59+instance ToParamSchema Color

60+

61+colorSchemaJSON :: Value

62+colorSchemaJSON = [aesonQQ|

63+{

64+ "type": "string",

65+ "enum": ["Red", "Green", "Blue"]

66+}

67+|]

68+

69+-- ========================================================================

70+-- Status (constructorTagModifier)

71+-- ========================================================================

72+

73+data Status = StatusOk | StatusError deriving (Generic)

74+

75+instance ToParamSchema Status where

76+ toParamSchema = genericToParamSchema defaultSchemaOptions

77+ { constructorTagModifier = map toLower . drop (length "Status") }

78+

79+statusSchemaJSON :: Value

80+statusSchemaJSON = [aesonQQ|

81+{

82+ "type": "string",

83+ "enum": ["ok", "error"]

84+}

85+|]

86+

87+-- ========================================================================

88+-- Email (newtype with unwrapUnaryRecords set to True)

89+-- ========================================================================

90+

91+newtype Email = Email { getEmail :: String }

92+ deriving (Generic)

93+instance ToParamSchema Email

94+

95+emailSchemaJSON :: Value

96+emailSchemaJSON = [aesonQQ|

97+{

98+ "type": "string"

99+}

100+|]

101+

102+-- ========================================================================

103+-- UserId (non-record newtype)

104+-- ========================================================================

105+

106+newtype UserId = UserId Integer

107+ deriving (Generic)

108+instance ToParamSchema UserId

109+

110+userIdSchemaJSON :: Value

111+userIdSchemaJSON = [aesonQQ|

112+{

113+ "type": "integer"

114+}

115+|]

116+

test/Data/Swagger/Schema/GeneratorSpec.hsdeleted−168

@@ -1,168 +0,0 @@

1−{-# LANGUAGE OverloadedLists #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE PackageImports #-}

4−module Data.Swagger.Schema.GeneratorSpec where

5−

6−import Prelude ()

7−import Prelude.Compat

8−

9−import Data.Swagger

10−import Data.Swagger.Schema.Generator

11−

12−import Control.Lens.Operators

13−import Data.Aeson

14−import Data.Hashable (Hashable)

15−import Data.HashMap.Strict (HashMap)

16−import qualified Data.HashMap.Strict as HashMap

17−import "unordered-containers" Data.HashSet (HashSet)

18−import qualified "unordered-containers" Data.HashSet as HashSet

19−import Data.Int

20−import Data.IntMap (IntMap)

21−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

22−import Data.Map (Map, fromList)

23−import Data.Monoid (mempty)

24−import Data.Proxy

25−import Data.Proxy

26−import Data.Set (Set)

27−import qualified Data.Text as T

28−import qualified Data.Text.Lazy as TL

29−import Data.Time

30−import Data.Version (Version)

31−import Data.Word

32−import GHC.Generics

33−

34−import Test.Hspec

35−import Test.Hspec.QuickCheck

36−import Test.QuickCheck

37−

38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

39−shouldValidate = validateFromJSON

40−

41−

42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

43−shouldNotValidate = expectFailure . shouldValidate

44−

45−

46−spec :: Spec

47−spec = do

48− describe "FromJSON validation" $ do

49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)

50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)

51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)

52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)

53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)

54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)

55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)

56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)

57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)

58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)

59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)

60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)

61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)

62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)

63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)

64− prop "String" $ shouldValidate (Proxy :: Proxy String)

65− prop "()" $ shouldValidate (Proxy :: Proxy ())

66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)

67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)

68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)

69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)

70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])

71− -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

74− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))

79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))

80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))

81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

82− prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

83− prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

84− prop "Object" $ shouldValidate (Proxy :: Proxy Object)

85− prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

86− prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

87− prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

88− describe "Invalid FromJSON validation" $ do

89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)

90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)

91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)

92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)

93−

94−-- =============================

95−-- Data types and bunk instances

96−-- =============================

97−

98−data WrongType = WrongType Bool

99−

100−instance FromJSON WrongType where

101− parseJSON = withBool "WrongType" $ return . WrongType

102−

103−instance ToSchema WrongType where

104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $

105− mempty

106− & type_ ?~ SwaggerObject

107−

108−

109−data MissingRequired = MissingRequired

110− { propA :: String

111− , propB :: Bool

112− }

113−

114−instance FromJSON MissingRequired where

115− parseJSON = withObject "MissingRequired" $ \o ->

116− MissingRequired

117− <$> o .: "propA"

118− <*> o .: "propB"

119−

120−instance ToSchema MissingRequired where

121− declareNamedSchema _ = do

122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)

123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

124− return . NamedSchema (Just "MissingRequired") $

125− mempty

126− & type_ ?~ SwaggerObject

127− & properties .~ [("propA", stringSchema)

128− ,("propB", boolSchema)

129− ]

130− & required .~ ["propA"]

131−

132−data MissingProperty = MissingProperty

133− { propC :: String

134− , propD :: Bool

135− }

136−

137−instance FromJSON MissingProperty where

138− parseJSON = withObject "MissingProperty" $ \o ->

139− MissingProperty

140− <$> o .: "propC"

141− <*> o .: "propD"

142−

143−instance ToSchema MissingProperty where

144− declareNamedSchema _ = do

145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)

146− return . NamedSchema (Just "MissingProperty") $

147− mempty

148− & type_ ?~ SwaggerObject

149− & properties .~ [("propC", stringSchema)]

150− & required .~ ["propC"]

151−

152−data WrongPropType = WrongPropType

153− { propE :: String

154− }

155−

156−instance FromJSON WrongPropType where

157− parseJSON = withObject "WrongPropType" $ \o ->

158− WrongPropType

159− <$> o .: "propE"

160−

161−instance ToSchema WrongPropType where

162− declareNamedSchema _ = do

163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

164− return . NamedSchema (Just "WrongPropType") $

165− mempty

166− & type_ ?~ SwaggerObject

167− & properties .~ [("propE", boolSchema)]

168− & required .~ ["propE"]

test/Data/Swagger/Schema/ValidationSpec.hs+65−130

@@ -1,50 +1,43 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE PackageImports #-}

3+{-# LANGUAGE PackageImports #-}

4−{-# LANGUAGE RecordWildCards #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# OPTIONS_GHC -fno-warn-orphans #-}

7module Data.Swagger.Schema.ValidationSpec where

4module Data.Swagger.Schema.ValidationSpec where

9−import Control.Applicative

6+import Control.Applicative

10−import Control.Lens ((&), (.~), (?~))

11−import Data.Aeson

7+import Data.Aeson

12−import Data.Aeson.Types

8+import Data.Aeson.Types

13−import Data.Hashable (Hashable)

9+import Data.Int

14−import Data.HashMap.Strict (HashMap)

10+import Data.IntMap (IntMap)

15−import qualified Data.HashMap.Strict as HashMap

11+import qualified Data.IntMap as IntMap

12+import Data.IntSet (IntSet)

13+import Data.Hashable (Hashable)

16−import "unordered-containers" Data.HashSet (HashSet)

14+import "unordered-containers" Data.HashSet (HashSet)

17import qualified "unordered-containers" Data.HashSet as HashSet

15import qualified "unordered-containers" Data.HashSet as HashSet

18−import Data.Int

16+import Data.HashMap.Strict (HashMap)

19−import Data.IntMap (IntMap)

17+import qualified Data.HashMap.Strict as HashMap

20−import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

21−import Data.Map (Map, fromList)

18+import Data.Map (Map)

22−import Data.Monoid (mempty)

19+import qualified Data.Map as Map

23−import Data.Proxy

20+import Data.Proxy

24−import Data.Set (Set)

21+import Data.Time

25−import qualified Data.Text as T

22+import qualified Data.Text as T

26−import qualified Data.Text.Lazy as TL

23+import qualified Data.Text.Lazy as TL

27−import Data.Time

24+import Data.Set (Set)

28−import Data.Version (Version)

25+import qualified Data.Set as Set

29−import Data.Word

26+import Data.Word

30−import GHC.Generics

27+import GHC.Generics

31−

28+

32−import Data.Swagger

29+import Data.Swagger

33−import Data.Swagger.Declare

30+import Data.Swagger.Declare

34−

31+import Data.Swagger.Schema.Validation

35−import Test.Hspec

32+

33+import SpecCommon

36−import Test.Hspec.QuickCheck

34+import Test.Hspec

37−import Test.QuickCheck

35+import Test.Hspec.QuickCheck

38−import Test.QuickCheck.Instances ()

36+import Test.QuickCheck

40shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

38shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

41shouldValidate _ x = validateToJSON x == []

39shouldValidate _ 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−

48spec :: Spec

41spec :: Spec

49spec = do

42spec = do

50 describe "Validation" $ do

43 describe "Validation" $ do

@@ -73,7 +66,6 @@ spec = do

73 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

66 -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))

74 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

67 prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

75 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

68 prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

76− prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

77 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

69 prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

78 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

70 prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

79 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

71 prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

@@ -83,7 +75,6 @@ spec = do

83 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

75 prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

84 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

76 prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))

85 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

77 prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))

86− prop "Object" $ shouldValidate (Proxy :: Proxy Object)

87 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

78 prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))

88 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

79 prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))

89 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

80 prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))

@@ -92,16 +83,6 @@ spec = do

92 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

83 prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)

93 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

84 prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)

94 prop "Light" $ shouldValidate (Proxy :: Proxy Light)

85 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

106main :: IO ()

87main :: IO ()

107main = hspec spec

88main = hspec spec

@@ -121,13 +102,6 @@ instance ToSchema Person

121instance Arbitrary Person where

102instance Arbitrary Person where

122 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

103 arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary

123

104

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−

131-- ========================================================================

105-- ========================================================================

132-- Color (enum)

106-- Color (enum)

133-- ========================================================================

107-- ========================================================================

@@ -139,11 +113,6 @@ instance ToSchema Color

139instance Arbitrary Color where

113instance Arbitrary Color where

140 arbitrary = arbitraryBoundedEnum

114 arbitrary = arbitraryBoundedEnum

141

115

142−invalidColorToJSON :: Color -> Value

143−invalidColorToJSON Red = toJSON "red"

144−invalidColorToJSON Green = toJSON "green"

145−invalidColorToJSON Blue = toJSON "blue"

146−

147-- ========================================================================

116-- ========================================================================

148-- Paint (record with bounded enum property)

117-- Paint (record with bounded enum property)

149-- ========================================================================

118-- ========================================================================

@@ -157,9 +126,6 @@ instance ToSchema Paint

157instance Arbitrary Paint where

126instance Arbitrary Paint where

158 arbitrary = Paint <$> arbitrary

127 arbitrary = Paint <$> arbitrary

159

128

160−invalidPaintToJSON :: Paint -> Value

161−invalidPaintToJSON = toJSON . color

162−

163-- ========================================================================

129-- ========================================================================

164-- MyRoseTree (custom datatypeNameModifier)

130-- MyRoseTree (custom datatypeNameModifier)

165-- ========================================================================

131-- ========================================================================

@@ -188,8 +154,7 @@ instance Arbitrary MyRoseTree where

188

154

189data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)

155data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)

190

156

191−instance ToSchema Light where

157+instance ToSchema Light

192− declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions

193

158

194instance ToJSON Light where

159instance ToJSON Light where

195 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

160 toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }

@@ -201,78 +166,48 @@ instance Arbitrary Light where

201 , LightColor <$> arbitrary

166 , LightColor <$> arbitrary

202 ]

167 ]

203

168

204−invalidLightToJSON :: Light -> Value

169+-- Arbitrary instances for common types

205−invalidLightToJSON = genericToJSON defaultOptions

206−

207−-- ========================================================================

208−-- ButtonImages (bounded enum key mapping)

209−-- ========================================================================

210−

211−data ButtonState = Neutral | Focus | Active | Hover | Disabled

212− deriving (Show, Eq, Ord, Bounded, Enum, Generic)

213−

214−instance ToJSON ButtonState

215−instance ToSchema ButtonState

216−instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)

217−

218−instance Arbitrary ButtonState where

219− arbitrary = arbitraryBoundedEnum

220−

221−type ImageUrl = T.Text

222

170

223−newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }

171+#if MIN_VERSION_QuickCheck(2,8,2)

224− deriving (Show, Generic)

172+#else

173+instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where

174+ arbitrary = Map.fromList <$> arbitrary

225

175

226−instance ToJSON ButtonImages where

176+instance Arbitrary a => Arbitrary (IntMap a) where

227− toJSON = toJSON . getButtonImages

177+ arbitrary = IntMap.fromList <$> arbitrary

228

178

229−instance ToSchema ButtonImages where

179+instance (Ord a, Arbitrary a) => Arbitrary (Set a) where

230− declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions

180+ arbitrary = Set.fromList <$> arbitrary

231− declareSchemaBoundedEnumKeyMapping

181+#endif

232

182

233−invalidButtonImagesToJSON :: ButtonImages -> Value

183+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where

234−invalidButtonImagesToJSON = genericToJSON defaultOptions

184+ arbitrary = HashMap.fromList <$> arbitrary

235

185

236−instance Arbitrary ButtonImages where

186+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where

237− arbitrary = ButtonImages <$> arbitrary

187+ arbitrary = HashSet.fromList <$> arbitrary

238

188

239−-- ========================================================================

189+instance Arbitrary T.Text where

240−-- FreeForm (wraps a raw JSON Value)

190+ arbitrary = T.pack <$> arbitrary

241−-- ========================================================================

242

191

243−data FreeForm = FreeForm { jsonContent :: Map T.Text Value }

192+instance Arbitrary TL.Text where

244− deriving (Show, Generic)

193+ arbitrary = TL.pack <$> arbitrary

245

194

246−instance ToJSON FreeForm where

195+instance Arbitrary Day where

247− toJSON = toJSON . jsonContent

196+ arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary

248

197

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

198+instance Arbitrary LocalTime where

255− arbitrary = (FreeForm . fromList) <$> genObj

199+ arbitrary = LocalTime

256− where

200+ <$> arbitrary

257− genObj = listOf $ do

201+ <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))

258− k <- arbitrary

259− v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]

260− pure (k, v)

261

202

262instance Eq ZonedTime where

203instance Eq ZonedTime where

263 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

204 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y

264

205

265−-- ========================================================================

206+instance Arbitrary ZonedTime where

266−-- Arbitrary instance for Data.Aeson.Value

207+ arbitrary = ZonedTime

267−-- ========================================================================

208+ <$> arbitrary

209+ <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))

210+

211+instance Arbitrary UTCTime where

212+ arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))

268

213

269−instance Arbitrary Value where

270− -- Weights are almost random

271− -- Uniform oneof tends not to build complex objects cause of recursive call.

272− arbitrary = resize 4 $ frequency

273− [ (3, Object <$> arbitrary)

274− , (3, Array <$> arbitrary)

275− , (3, String <$> arbitrary)

276− , (3, Number <$> arbitrary)

277− , (3, Bool <$> arbitrary)

278− , (1, return Null) ]

test/Data/Swagger/SchemaSpec.hs+547−12

@@ -8,22 +8,23 @@ import Prelude ()

8import Prelude.Compat

10import Control.Lens ((^.))

11−import Data.Aeson (Value)

11+import Data.Aeson

12+import Data.Aeson.QQ

13+import Data.Char

14+import qualified Data.HashMap.Strict as HashMap

12import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

15import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap

13import Data.Proxy

16import Data.Proxy

14import Data.Set (Set)

17import Data.Set (Set)

18+import qualified Data.Set as Set

15import qualified Data.Text as Text

19import qualified Data.Text as Text

20+import GHC.Generics

17import Data.Swagger

22import Data.Swagger

18import Data.Swagger.Declare

23import Data.Swagger.Declare

20−import Data.Swagger.CommonTestTypes

21import SpecCommon

25import SpecCommon

22import Test.Hspec

26import Test.Hspec

24−import qualified Data.HashMap.Strict as HM

25−import Data.Time.LocalTime

26−

27checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

28checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

28checkToSchema proxy js = toSchema proxy <=> js

29checkToSchema proxy js = toSchema proxy <=> js

@@ -77,10 +78,8 @@ spec = do

77 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON

78 context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON

78 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON

79 context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON

79 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON

80 context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON

80− context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON

81 context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON

82 context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

83− context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

84 context "Sum types" $ do

83 context "Sum types" $ do

85 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON

84 context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON

86 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON

85 context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON

@@ -96,7 +95,6 @@ spec = do

96 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]

95 context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]

97 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

96 context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]

98 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

97 context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]

99− context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]

100 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

98 context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]

101 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []

99 context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []

102 describe "Inlining Schemas" $ do

100 describe "Inlining Schemas" $ do

@@ -105,10 +103,547 @@ spec = do

105 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

103 context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON

106 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

104 context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON

107 context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON

105 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

112

106

113main :: IO ()

107main :: IO ()

114main = hspec spec

108main = hspec spec

109+

110+-- ========================================================================

111+-- Person (simple record with optional fields)

112+-- ========================================================================

113+data Person = Person

114+ { name :: String

115+ , phone :: Integer

116+ , email :: Maybe String

117+ } deriving (Generic)

118+

119+instance ToSchema Person

120+

121+personSchemaJSON :: Value

122+personSchemaJSON = [aesonQQ|

123+{

124+ "type": "object",

125+ "properties":

126+ {

127+ "name": { "type": "string" },

128+ "phone": { "type": "integer" },

129+ "email": { "type": "string" }

130+ },

131+ "required": ["name", "phone"]

132+}

133+|]

134+

135+-- ========================================================================

136+-- ISPair (non-record product data type)

137+-- ========================================================================

138+data ISPair = ISPair Integer String

139+ deriving (Generic)

140+

141+instance ToSchema ISPair

142+

143+ispairSchemaJSON :: Value

144+ispairSchemaJSON = [aesonQQ|

145+{

146+ "type": "array",

147+ "items":

148+ [

149+ { "type": "integer" },

150+ { "type": "string" }

151+ ]

152+}

153+|]

154+

155+-- ========================================================================

156+-- Point (record data type with custom fieldLabelModifier)

157+-- ========================================================================

158+

159+data Point = Point

160+ { pointX :: Double

161+ , pointY :: Double

162+ } deriving (Generic)

163+

164+instance ToSchema Point where

165+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

166+ { fieldLabelModifier = map toLower . drop (length "point") }

167+

168+pointSchemaJSON :: Value

169+pointSchemaJSON = [aesonQQ|

170+{

171+ "type": "object",

172+ "properties":

173+ {

174+ "x": { "type": "number", "format": "double" },

175+ "y": { "type": "number", "format": "double" }

176+ },

177+ "required": ["x", "y"]

178+}

179+|]

180+

181+-- ========================================================================

182+-- Point (record data type with multiple fields)

183+-- ========================================================================

184+

185+data Point5 = Point5

186+ { point5X :: Double

187+ , point5Y :: Double

188+ , point5Z :: Double

189+ , point5U :: Double

190+ , point5V :: Double -- 5 dimensional!

191+ } deriving (Generic)

192+

193+instance ToSchema Point5 where

194+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

195+ { fieldLabelModifier = map toLower . drop (length "point5") }

196+

197+point5SchemaJSON :: Value

198+point5SchemaJSON = [aesonQQ|

199+{

200+ "type": "object",

201+ "properties":

202+ {

203+ "x": { "type": "number", "format": "double" },

204+ "y": { "type": "number", "format": "double" },

205+ "z": { "type": "number", "format": "double" },

206+ "u": { "type": "number", "format": "double" },

207+ "v": { "type": "number", "format": "double" }

208+ },

209+ "required": ["x", "y", "z", "u", "v"]

210+}

211+|]

212+

213+point5Properties :: [String]

214+point5Properties = ["x", "y", "z", "u", "v"]

215+

216+-- ========================================================================

217+-- Color (enum)

218+-- ========================================================================

219+data Color

220+ = Red

221+ | Green

222+ | Blue

223+ deriving (Generic)

224+instance ToSchema Color

225+

226+colorSchemaJSON :: Value

227+colorSchemaJSON = [aesonQQ|

228+{

229+ "type": "string",

230+ "enum": ["Red", "Green", "Blue"]

231+}

232+|]

233+

234+-- ========================================================================

235+-- Shade (paramSchemaToNamedSchema)

236+-- ========================================================================

237+

238+data Shade = Dim | Bright deriving (Generic)

239+instance ToParamSchema Shade

240+

241+instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions

242+

243+shadeSchemaJSON :: Value

244+shadeSchemaJSON = [aesonQQ|

245+{

246+ "type": "string",

247+ "enum": ["Dim", "Bright"]

248+}

249+|]

250+

251+-- ========================================================================

252+-- Paint (record with bounded enum property)

253+-- ========================================================================

254+

255+newtype Paint = Paint { color :: Color }

256+ deriving (Generic)

257+instance ToSchema Paint

258+

259+paintSchemaJSON :: Value

260+paintSchemaJSON = [aesonQQ|

261+{

262+ "type": "object",

263+ "properties":

264+ {

265+ "color":

266+ {

267+ "$ref": "#/definitions/Color"

268+ }

269+ },

270+ "required": ["color"]

271+}

272+|]

273+

274+paintInlinedSchemaJSON :: Value

275+paintInlinedSchemaJSON = [aesonQQ|

276+{

277+ "type": "object",

278+ "properties":

279+ {

280+ "color":

281+ {

282+ "type": "string",

283+ "enum": ["Red", "Green", "Blue"]

284+ }

285+ },

286+ "required": ["color"]

287+}

288+|]

289+

290+-- ========================================================================

291+-- Email (newtype with unwrapUnaryRecords set to True)

292+-- ========================================================================

293+

294+newtype Email = Email { getEmail :: String }

295+ deriving (Generic)

296+

297+instance ToSchema Email where

298+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

299+ { unwrapUnaryRecords = True }

300+

301+emailSchemaJSON :: Value

302+emailSchemaJSON = [aesonQQ|

303+{

304+ "type": "string"

305+}

306+|]

307+

308+-- ========================================================================

309+-- UserId (non-record newtype)

310+-- ========================================================================

311+

312+newtype UserId = UserId Integer

313+ deriving (Eq, Ord, Generic)

314+instance ToSchema UserId

315+

316+userIdSchemaJSON :: Value

317+userIdSchemaJSON = [aesonQQ|

318+{

319+ "type": "integer"

320+}

321+|]

322+

323+-- ========================================================================

324+-- UserGroup (set newtype)

325+-- ========================================================================

326+

327+newtype UserGroup = UserGroup (Set UserId)

328+ deriving (Generic)

329+instance ToSchema UserGroup

330+

331+userGroupSchemaJSON :: Value

332+userGroupSchemaJSON = [aesonQQ|

333+{

334+ "type": "array",

335+ "items": { "$ref": "#/definitions/UserId" },

336+ "uniqueItems": true

337+}

338+|]

339+

340+-- ========================================================================

341+-- Player (record newtype)

342+-- ========================================================================

343+

344+newtype Player = Player

345+ { position :: Point

346+ } deriving (Generic)

347+instance ToSchema Player

348+

349+playerSchemaJSON :: Value

350+playerSchemaJSON = [aesonQQ|

351+{

352+ "type": "object",

353+ "properties":

354+ {

355+ "position":

356+ {

357+ "$ref": "#/definitions/Point"

358+ }

359+ },

360+ "required": ["position"]

361+}

362+|]

363+

364+-- ========================================================================

365+-- MyRoseTree (custom datatypeNameModifier)

366+-- ========================================================================

367+

368+data MyRoseTree = MyRoseTree

369+ { root :: String

370+ , trees :: [MyRoseTree]

371+ } deriving (Generic)

372+

373+instance ToSchema MyRoseTree where

374+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

375+ { datatypeNameModifier = drop (length "My") }

376+

377+myRoseTreeSchemaJSON :: Value

378+myRoseTreeSchemaJSON = [aesonQQ|

379+{

380+ "type": "object",

381+ "properties":

382+ {

383+ "root": { "type": "string" },

384+ "trees":

385+ {

386+ "type": "array",

387+ "items":

388+ {

389+ "$ref": "#/definitions/RoseTree"

390+ }

391+ }

392+ },

393+ "required": ["root", "trees"]

394+}

395+|]

396+

397+-- ========================================================================

398+-- Inlined (newtype for inlining schemas)

399+-- ========================================================================

400+

401+newtype Inlined a = Inlined { getInlined :: a }

402+

403+instance ToSchema a => ToSchema (Inlined a) where

404+ declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

405+ where

406+ unname (NamedSchema _ s) = NamedSchema Nothing s

407+

408+newtype Players = Players [Inlined Player]

409+ deriving (Generic)

410+instance ToSchema Players

411+

412+playersSchemaJSON :: Value

413+playersSchemaJSON = [aesonQQ|

414+{

415+ "type": "array",

416+ "items":

417+ {

418+ "type": "object",

419+ "properties":

420+ {

421+ "position":

422+ {

423+ "$ref": "#/definitions/Point"

424+ }

425+ },

426+ "required": ["position"]

427+ }

428+}

429+|]

430+

431+-- ========================================================================

432+-- Status (sum type with unary constructors)

433+-- ========================================================================

434+

435+data Status

436+ = StatusOk String

437+ | StatusError String

438+ deriving (Generic)

439+

440+instance ToSchema Status where

441+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

442+ { constructorTagModifier = map toLower . drop (length "Status") }

443+

444+statusSchemaJSON :: Value

445+statusSchemaJSON = [aesonQQ|

446+{

447+ "type": "object",

448+ "properties":

449+ {

450+ "ok": { "type": "string" },

451+ "error": { "type": "string" }

452+ },

453+ "maxProperties": 1,

454+ "minProperties": 1

455+}

456+|]

457+

458+-- ========================================================================

459+-- Unit type

460+-- ========================================================================

461+

462+data Unit = Unit deriving (Generic)

463+instance ToSchema Unit

464+

465+unitSchemaJSON :: Value

466+unitSchemaJSON = [aesonQQ|

467+{

468+ "type": "string",

469+ "enum": ["Unit"]

470+}

471+|]

472+

473+

474+-- ========================================================================

475+-- Character (sum type with ref and record in alternative)

476+-- ========================================================================

477+

478+data Character

479+ = PC Player

480+ | NPC { npcName :: String, npcPosition :: Point }

481+ deriving (Generic)

482+instance ToSchema Character

483+

484+characterSchemaJSON :: Value

485+characterSchemaJSON = [aesonQQ|

486+{

487+ "type": "object",

488+ "properties":

489+ {

490+ "PC": { "$ref": "#/definitions/Player" },

491+ "NPC":

492+ {

493+ "type": "object",

494+ "properties":

495+ {

496+ "npcName": { "type": "string" },

497+ "npcPosition": { "$ref": "#/definitions/Point" }

498+ },

499+ "required": ["npcName", "npcPosition"]

500+ }

501+ },

502+ "maxProperties": 1,

503+ "minProperties": 1

504+}

505+|]

506+

507+characterInlinedSchemaJSON :: Value

508+characterInlinedSchemaJSON = [aesonQQ|

509+{

510+ "type": "object",

511+ "properties":

512+ {

513+ "PC":

514+ {

515+ "type": "object",

516+ "properties":

517+ {

518+ "position":

519+ {

520+ "type": "object",

521+ "properties":

522+ {

523+ "x": { "type": "number", "format": "double" },

524+ "y": { "type": "number", "format": "double" }

525+ },

526+ "required": ["x", "y"]

527+ }

528+ },

529+ "required": ["position"]

530+ },

531+ "NPC":

532+ {

533+ "type": "object",

534+ "properties":

535+ {

536+ "npcName": { "type": "string" },

537+ "npcPosition":

538+ {

539+ "type": "object",

540+ "properties":

541+ {

542+ "x": { "type": "number", "format": "double" },

543+ "y": { "type": "number", "format": "double" }

544+ },

545+ "required": ["x", "y"]

546+ }

547+ },

548+ "required": ["npcName", "npcPosition"]

549+ }

550+ },

551+ "maxProperties": 1,

552+ "minProperties": 1

553+}

554+|]

555+

556+characterInlinedPlayerSchemaJSON :: Value

557+characterInlinedPlayerSchemaJSON = [aesonQQ|

558+{

559+ "type": "object",

560+ "properties":

561+ {

562+ "PC":

563+ {

564+ "type": "object",

565+ "properties":

566+ {

567+ "position":

568+ {

569+ "$ref": "#/definitions/Point"

570+ }

571+ },

572+ "required": ["position"]

573+ },

574+ "NPC":

575+ {

576+ "type": "object",

577+ "properties":

578+ {

579+ "npcName": { "type": "string" },

580+ "npcPosition": { "$ref": "#/definitions/Point" }

581+ },

582+ "required": ["npcName", "npcPosition"]

583+ }

584+ },

585+ "maxProperties": 1,

586+ "minProperties": 1

587+}

588+|]

589+

590+-- ========================================================================

591+-- Light (sum type with unwrapUnaryRecords)

592+-- ========================================================================

593+

594+data Light

595+ = NoLight

596+ | LightFreq Double

597+ | LightColor Color

598+ | LightWaveLength { waveLength :: Double }

599+ deriving (Generic)

600+

601+instance ToSchema Light where

602+ declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

603+ { unwrapUnaryRecords = True }

604+

605+lightSchemaJSON :: Value

606+lightSchemaJSON = [aesonQQ|

607+{

608+ "type": "object",

609+ "properties":

610+ {

611+ "NoLight": { "type": "array", "items": [] },

612+ "LightFreq": { "type": "number", "format": "double" },

613+ "LightColor": { "$ref": "#/definitions/Color" },

614+ "LightWaveLength": { "type": "number", "format": "double" }

615+ },

616+ "maxProperties": 1,

617+ "minProperties": 1

618+}

619+|]

620+

621+lightInlinedSchemaJSON :: Value

622+lightInlinedSchemaJSON = [aesonQQ|

623+{

624+ "type": "object",

625+ "properties":

626+ {

627+ "NoLight": { "type": "array", "items": [] },

628+ "LightFreq": { "type": "number", "format": "double" },

629+ "LightColor":

630+ {

631+ "type": "string",

632+ "enum": ["Red", "Green", "Blue"]

633+ },

634+ "LightWaveLength": { "type": "number", "format": "double" }

635+ },

636+ "maxProperties": 1,

637+ "minProperties": 1

638+}

639+|]

640+

641+-- ========================================================================

642+-- ResourceId (series of newtypes)

643+-- ========================================================================

644+

645+newtype Id = Id String deriving (Generic)

646+instance ToSchema Id

647+

648+newtype ResourceId = ResourceId Id deriving (Generic)

649+instance ToSchema ResourceId

test/Data/SwaggerSpec.hs+28−114

@@ -10,9 +10,9 @@ import Prelude.Compat

10import Control.Lens

12import Data.Aeson

13−import Data.Aeson.QQ.Simple

13+import Data.Aeson.QQ

14import Data.HashMap.Strict (HashMap)

15−import qualified Data.HashSet.InsOrd as InsOrdHS

15+import qualified Data.Set as Set

16import Data.Text (Text)

18import Data.Swagger

@@ -37,14 +37,11 @@ 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

41 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

40 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

42 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

41 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

43 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

42 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

44 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

43 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

45 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

44 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

47− describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

48 describe "Swagger Object" $ do

45 describe "Swagger Object" $ do

49 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

46 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

50 context "PetStore Example" $

47 context "PetStore Example" $

@@ -128,7 +125,7 @@ licenseExampleJSON = [aesonQQ|

128

125

129operationExample :: Operation

126operationExample :: Operation

130operationExample = mempty

127operationExample = mempty

131− & tags .~ InsOrdHS.fromList ["pet"]

128+ & tags .~ Set.fromList ["pet"]

132 & summary ?~ "Updates a pet in the store with form data"

129 & summary ?~ "Updates a pet in the store with form data"

133 & description ?~ ""

130 & description ?~ ""

134 & operationId ?~ "updatePetWithForm"

131 & operationId ?~ "updatePetWithForm"

@@ -159,7 +156,7 @@ operationExample = mempty

159 stringSchema :: ParamLocation -> ParamOtherSchema

156 stringSchema :: ParamLocation -> ParamOtherSchema

160 stringSchema loc = mempty

157 stringSchema loc = mempty

161 & in_ .~ loc

158 & in_ .~ loc

162− & type_ ?~ SwaggerString

159+ & type_ .~ SwaggerString

163

160

164operationExampleJSON :: Value

161operationExampleJSON :: Value

165operationExampleJSON = [aesonQQ|

162operationExampleJSON = [aesonQQ|

@@ -225,7 +222,7 @@ operationExampleJSON = [aesonQQ|

225

222

226schemaPrimitiveExample :: Schema

223schemaPrimitiveExample :: Schema

227schemaPrimitiveExample = mempty

224schemaPrimitiveExample = mempty

228− & type_ ?~ SwaggerString

225+ & type_ .~ SwaggerString

229 & format ?~ "email"

226 & format ?~ "email"

230

227

231schemaPrimitiveExampleJSON :: Value

228schemaPrimitiveExampleJSON :: Value

@@ -238,14 +235,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

238

235

239schemaSimpleModelExample :: Schema

236schemaSimpleModelExample :: Schema

240schemaSimpleModelExample = mempty

237schemaSimpleModelExample = mempty

241− & type_ ?~ SwaggerObject

238+ & type_ .~ SwaggerObject

242 & required .~ [ "name" ]

239 & required .~ [ "name" ]

243 & properties .~

240 & properties .~

244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))

241+ [ ("name", Inline (mempty & type_ .~ SwaggerString))

245 , ("address", Ref (Reference "Address"))

242 , ("address", Ref (Reference "Address"))

246 , ("age", Inline $ mempty

243 , ("age", Inline $ mempty

247 & minimum_ ?~ 0

244 & minimum_ ?~ 0

248− & type_ ?~ SwaggerInteger

245+ & type_ .~ SwaggerInteger

249 & format ?~ "int32" ) ]

246 & format ?~ "int32" ) ]

250

247

251schemaSimpleModelExampleJSON :: Value

248schemaSimpleModelExampleJSON :: Value

@@ -273,8 +270,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

273

270

274schemaModelDictExample :: Schema

271schemaModelDictExample :: Schema

275schemaModelDictExample = mempty

272schemaModelDictExample = mempty

276− & type_ ?~ SwaggerObject

273+ & type_ .~ SwaggerObject

277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

274+ & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)

278

275

279schemaModelDictExampleJSON :: Value

276schemaModelDictExampleJSON :: Value

280schemaModelDictExampleJSON = [aesonQQ|

277schemaModelDictExampleJSON = [aesonQQ|

@@ -286,28 +283,15 @@ schemaModelDictExampleJSON = [aesonQQ|

286}

283}

287|]

284|]

288

285

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−

302schemaWithExampleExample :: Schema

286schemaWithExampleExample :: Schema

303schemaWithExampleExample = mempty

287schemaWithExampleExample = mempty

304− & type_ ?~ SwaggerObject

288+ & type_ .~ SwaggerObject

305 & properties .~

289 & properties .~

306 [ ("id", Inline $ mempty

290 [ ("id", Inline $ mempty

307− & type_ ?~ SwaggerInteger

291+ & type_ .~ SwaggerInteger

308 & format ?~ "int64" )

292 & format ?~ "int64" )

309 , ("name", Inline $ mempty

293 , ("name", Inline $ mempty

310− & type_ ?~ SwaggerString) ]

294+ & type_ .~ SwaggerString) ]

311 & required .~ [ "name" ]

295 & required .~ [ "name" ]

312 & example ?~ [aesonQQ|

296 & example ?~ [aesonQQ|

313 {

297 {

@@ -346,19 +330,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

346definitionsExample :: HashMap Text Schema

330definitionsExample :: HashMap Text Schema

347definitionsExample =

331definitionsExample =

348 [ ("Category", mempty

332 [ ("Category", mempty

349− & type_ ?~ SwaggerObject

333+ & type_ .~ SwaggerObject

350 & properties .~

334 & properties .~

351 [ ("id", Inline $ mempty

335 [ ("id", Inline $ mempty

352− & type_ ?~ SwaggerInteger

336+ & type_ .~ SwaggerInteger

353 & format ?~ "int64")

337 & format ?~ "int64")

354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

338+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

355 , ("Tag", mempty

339 , ("Tag", mempty

356− & type_ ?~ SwaggerObject

340+ & type_ .~ SwaggerObject

357 & properties .~

341 & properties .~

358 [ ("id", Inline $ mempty

342 [ ("id", Inline $ mempty

359− & type_ ?~ SwaggerInteger

343+ & type_ .~ SwaggerInteger

360 & format ?~ "int64")

344 & format ?~ "int64")

361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

345+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

362

346

363definitionsExampleJSON :: Value

347definitionsExampleJSON :: Value

364definitionsExampleJSON = [aesonQQ|

348definitionsExampleJSON = [aesonQQ|

@@ -402,7 +386,7 @@ paramsDefinitionExample =

402 & required ?~ True

386 & required ?~ True

403 & schema .~ ParamOther (mempty

387 & schema .~ ParamOther (mempty

404 & in_ .~ ParamQuery

388 & in_ .~ ParamQuery

405− & type_ ?~ SwaggerInteger

389+ & type_ .~ SwaggerInteger

406 & format ?~ "int32" ))

390 & format ?~ "int32" ))

407 , ("limitParam", mempty

391 , ("limitParam", mempty

408 & name .~ "limit"

392 & name .~ "limit"

@@ -410,7 +394,7 @@ paramsDefinitionExample =

410 & required ?~ True

394 & required ?~ True

411 & schema .~ ParamOther (mempty

395 & schema .~ ParamOther (mempty

412 & in_ .~ ParamQuery

396 & in_ .~ ParamQuery

413− & type_ ?~ SwaggerInteger

397+ & type_ .~ SwaggerInteger

414 & format ?~ "int32" )) ]

398 & format ?~ "int32" )) ]

415

399

416paramsDefinitionExampleJSON :: Value

400paramsDefinitionExampleJSON :: Value

@@ -460,8 +444,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

460-- Responses Definition object

444-- Responses Definition object

461-- =======================================================================

445-- =======================================================================

462

446

463−securityDefinitionsExample :: SecurityDefinitions

447+securityDefinitionsExample :: HashMap Text SecurityScheme

464−securityDefinitionsExample = SecurityDefinitions

448+securityDefinitionsExample =

465 [ ("api_key", SecurityScheme

449 [ ("api_key", SecurityScheme

466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

450 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

467 , _securitySchemeDescription = Nothing })

451 , _securitySchemeDescription = Nothing })

@@ -493,46 +477,6 @@ securityDefinitionsExampleJSON = [aesonQQ|

493}

477}

494|]

478|]

495

479

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−

536-- =======================================================================

480-- =======================================================================

537-- Swagger object

481-- Swagger object

538-- =======================================================================

482-- =======================================================================

@@ -551,7 +495,7 @@ swaggerExample = mempty

551 & at 200 ?~ Inline (mempty

495 & at 200 ?~ Inline (mempty

552 & description .~ "OK"

496 & description .~ "OK"

553 & schema ?~ Inline (mempty

497 & schema ?~ Inline (mempty

554− & type_ ?~ SwaggerObject

498+ & type_ .~ SwaggerObject

555 & example ?~ [aesonQQ|

499 & example ?~ [aesonQQ|

556 {

500 {

557 "created": 100,

501 "created": 100,

@@ -560,9 +504,9 @@ swaggerExample = mempty

560 & description ?~ "This is some real Todo right here"

504 & description ?~ "This is some real Todo right here"

561 & properties .~

505 & properties .~

562 [ ("created", Inline $ mempty

506 [ ("created", Inline $ mempty

563− & type_ ?~ SwaggerInteger

507+ & type_ .~ SwaggerInteger

564 & format ?~ "int32")

508 & format ?~ "int32")

565− , ("description", Inline (mempty & type_ ?~ SwaggerString))]))

509+ , ("description", Inline (mempty & type_ .~ SwaggerString))]))

566 & produces ?~ MimeList [ "application/json" ]

510 & produces ?~ MimeList [ "application/json" ]

567 & parameters .~

511 & parameters .~

568 [ Inline $ mempty

512 [ Inline $ mempty

@@ -571,8 +515,8 @@ swaggerExample = mempty

571 & description ?~ "TodoId param"

515 & description ?~ "TodoId param"

572 & schema .~ ParamOther (mempty

516 & schema .~ ParamOther (mempty

573 & in_ .~ ParamPath

517 & in_ .~ ParamPath

574− & type_ ?~ SwaggerString ) ]

518+ & type_ .~ SwaggerString ) ]

575− & tags .~ InsOrdHS.fromList [ "todo" ] ))

519+ & tags .~ Set.fromList [ "todo" ] ))

576

520

577swaggerExampleJSON :: Value

521swaggerExampleJSON :: Value

578swaggerExampleJSON = [aesonQQ|

522swaggerExampleJSON = [aesonQQ|

@@ -1670,33 +1614,3 @@ petstoreExampleJSON = [aesonQQ|

1670 }

1614 }

1671}

1615}

1672|]

1616|]

1673−

1674−compositionSchemaExample :: Schema

1675−compositionSchemaExample = mempty

1676− & type_ ?~ SwaggerObject

1677− & Data.Swagger.allOf ?~ [

1678− Ref (Reference "Other")

1679− , Inline (mempty

1680− & type_ ?~ SwaggerObject

1681− & properties .~

1682− [ ("greet", Inline $ mempty

1683− & type_ ?~ SwaggerString) ])

1684− ]

1685−

1686−compositionSchemaExampleJSON :: Value

1687−compositionSchemaExampleJSON = [aesonQQ|

1688−{

1689− "type": "object",

1690− "allOf": [

1691− {

1692− "$ref": "#/definitions/Other"

1693− },

1694− {

1695− "type": "object",

1696− "properties": {

1697− "greet": { "type": "string" }

1698− }

1699− }

1700− ]

1701−}

1702−|]

test/DocTest.hsnew file+8

@@ -0,0 +1,8 @@

1+module Main (main) where

3+import System.FilePath.Glob (glob)

4+import Test.DocTest (doctest)

6+main :: IO ()

7+main = glob "src/**/*.hs" >>= doctest'

8+ where doctest' files = doctest $ "-Iinclude/" : "-D__DOCTEST__" : files

test/doctests.hsdeleted−12

@@ -1,12 +0,0 @@

1−module Main where

2−

3−import Build_doctests (flags, pkgs, module_sources)

4−import Data.Foldable (traverse_)

5−import Test.DocTest

6−

7−main :: IO ()

8−main = do

9− traverse_ putStrLn args

10− doctest args

11− where

12− args = flags ++ pkgs ++ module_sources