82fa102...master · typeable/swagger2

git.iko.soy/typeable/swagger2

29 files changed+1871−449

since splitsnapshots

unifiedsplit

.ghci+1 .travis.yml+134−87 CHANGELOG.md+67 aeson-0.11.cabal.config−1 cabal.project+2 examples/hackage.hs+1−1 src/Data/Swagger.hs+10−4 src/Data/Swagger/Declare.hs+4−5 src/Data/Swagger/Internal.hs+100−12 src/Data/Swagger/Internal/AesonUtils.hs+16−3 src/Data/Swagger/Internal/ParamSchema.hs+39−27 src/Data/Swagger/Internal/Schema.hs+82−73 src/Data/Swagger/Internal/Schema/Validation.hs+212−50 src/Data/Swagger/Internal/Utils.hs−1 src/Data/Swagger/Lens.hs+10−4 src/Data/Swagger/Operation.hs+5−5 src/Data/Swagger/Optics.hs+597 src/Data/Swagger/Schema/Generator.hs+114 src/Data/Swagger/Schema/Validation.hs+2 stack-ghc-8.0.yaml−5 stack-lts-2.yaml−22 stack.yaml+6−2 swagger2.cabal+82−55 test/Data/Swagger/CommonTestTypes.hs+45−18 test/Data/Swagger/ParamSchemaSpec.hs+7−2 test/Data/Swagger/Schema/GeneratorSpec.hs+168 test/Data/Swagger/Schema/ValidationSpec.hs+76−35 test/Data/Swagger/SchemaSpec.hs+5−6 test/Data/SwaggerSpec.hs+86−31

.ghci+1

@@ -1 +1,2 @@

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

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

.travis.yml+134−87

@@ -1,115 +1,162 @@

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

22#

3−# runghc make_travis_yml_2.hs '--branch' 'master' '--output' '.travis.yml' 'swagger2.cabal'

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

44#

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

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

6+#

7+# version: 0.5.20191020

68#

79language: c

8−sudo: false

9−

10+dist: xenial

1011git:

11− submodules: false # whether to recursively clone submodules

12−

12+ # whether to recursively clone submodules

13+ submodules: false

1314branches:

1415 only:

1516 - master

16−

1717cache:

1818 directories:

1919 - $HOME/.cabal/packages

2020 - $HOME/.cabal/store

21−

2221before_cache:

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

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

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

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

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

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

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

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

30−

31− - rm -rfv $HOME/.cabal/packages/head.hackage

32−

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

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

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

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

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

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

3330matrix:

3431 include:

35− - compiler: "ghc-7.8.4"

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

37− env: HADDOCK=false

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

39− - compiler: "ghc-7.10.3"

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

41− env: HADDOCK=false

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

43− - compiler: "ghc-8.0.2"

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

45− env: HADDOCK=false

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

47− - compiler: "ghc-8.2.2"

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

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

50− - compiler: "ghc-8.4.1"

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

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

53−

32+ - compiler: ghc-8.8.1

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

34+ - compiler: ghc-8.6.5

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

36+ - compiler: ghc-8.4.4

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

38+ - compiler: ghc-8.2.2

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

40+ - compiler: ghc-8.0.2

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

5442before_install:

55− - HC=${CC}

56− - HCPKG=${HC/ghc/ghc-pkg}

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"

5747 - unset CC

58− - ROOTDIR=$(pwd)

59− - mkdir -p $HOME/.local/bin

60− - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"

61− - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))

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

49+ - CABALHOME=$HOME/.cabal

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

51+ - TOP=$(pwd)

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

6253 - echo $HCNUMVER

63−

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

6474install:

65− - cabal --version

75+ - ${CABAL} --version

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

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

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

69− - HADDOCK=${HADDOCK-true}

70− - INSTALLED=${INSTALLED-true}

71− - GHCHEAD=${GHCHEAD-false}

72− - travis_retry cabal update -v

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

74− - rm -fv cabal.project cabal.project.local

75− - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'

76− - "printf 'packages: \".\"\\n' > cabal.project"

77− - cat cabal.project

78− - if [ -f "./configure.ac" ]; then

79− (cd "." && autoreconf -i);

80− fi

81− - rm -f cabal.project.freeze

82− - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all

83− - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all

84− - rm -rf .ghc.environment.* "."/dist

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

86−

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

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

77+ - TEST=--enable-tests

78+ - BENCH=--enable-benchmarks

79+ - HEADHACKAGE=false

80+ - rm -f $CABALHOME/config

81+ - |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

105+ - |

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

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

108+ - cat $CABALHOME/config

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

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

111+ # Generate cabal.project

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

113+ - touch cabal.project

114+ - |

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

116+ - |

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

118+ - cat cabal.project || true

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

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

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

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

123+ - rm cabal.project.freeze

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

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

89126script:

90− # test that source-distributions can be generated

91− - (cd "." && cabal sdist)

92− - mv "."/dist/swagger2-*.tar.gz ${DISTDIR}/

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

128+ # Packaging...

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

130+ # Unpacking...

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

93132 - cd ${DISTDIR} || false

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

95− - "printf 'packages: swagger2-*/*.cabal\\n' > cabal.project"

96− - cat cabal.project

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

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

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

99−

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

101− - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/$[a-zA-Z0-9-]\{1,\}$ */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi

102−

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

148+ # Building with tests and benchmarks...

103149 # build & run tests, build benchmarks

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

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

106−

107− # cabal check

108− - (cd swagger2-* && cabal check)

109−

110− # haddock

111− - rm -rf ./dist-newstyle

112− - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi

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

151+ # Testing...

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

153+ # cabal check...

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

155+ # haddock...

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

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

158+ - rm -f cabal.project.local

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

113160

114−# REGENDATA ["--branch","master","--output",".travis.yml","swagger2.cabal"]

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

115162# EOF

CHANGELOG.md+67

@@ -1,3 +1,70 @@

1+2.5

2+---

4+Highlights:

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

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

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

9+Fixes and minor changes:

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

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

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

13+

14+2.4

15+---

16+

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

18+- Tags aren't sorted

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

20+- Schema type is optional

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

22+- Take concrete 'Proxy' as argument

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

24+- GHC-8.8 preparations

25+

26+2.3.1.1

27+-------

28+

29+- Allow `network-3.0`

30+

31+2.3.1

32+-----

33+

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

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

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

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

38+- Make nullary schemas valid

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

40+

41+2.3.0.1

42+-------

43+

44+- Support GHC-8.6

45+

46+2.3

47+---

48+

49+Major changes:

50+

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

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

53+

54+Dependencies and CI:

55+

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

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

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

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

60+

61+2.2.2

62+-----

63+

64+* Add `ToSchema Version` instance

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

66+* PVP bounds

67+

1682.2.1

269-----

370

aeson-0.11.cabal.configdeleted−1

@@ -1 +0,0 @@

1−constraints: aeson ==0.11.*

cabal.projectnew file+2

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

1+packages: .

2+tests: true

examples/hackage.hs+1−1

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

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

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

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

30− & type_ .~ SwaggerObject

30+ & type_ ?~ SwaggerObject

3131 & properties .~

3232 [ ("summaryUsername", usernameSchema )

3333 , ("summaryUserid" , useridSchema )

src/Data/Swagger.hs+10−4

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

3131

3232 -- * Re-exports

3333 module Data.Swagger.Lens,

34+ module Data.Swagger.Optics,

3435 module Data.Swagger.Operation,

3536 module Data.Swagger.ParamSchema,

3637 module Data.Swagger.Schema,

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

7778 SwaggerItems(..),

7879 Xml(..),

7980 Pattern,

81+ AdditionalProperties(..),

8082

8183 -- ** Responses

8284 Responses(..),

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

8789 SecurityScheme(..),

8890 SecuritySchemeType(..),

8991 SecurityRequirement(..),

92+ SecurityDefinitions(..),

9093

9194 -- *** API key

9295 ApiKeyParams(..),

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

111114) where

112115

113116import Data.Swagger.Lens

117+import Data.Swagger.Optics ()

114118import Data.Swagger.Operation

115119import Data.Swagger.ParamSchema

116120import Data.Swagger.Schema

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

174178

175179-- $lens

176180--

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

182+--

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

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

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

180186--

181187-- >>> :{

182188-- encode $ (mempty :: Swagger)

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

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

184190-- & paths .~

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

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

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

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

204210-- >>> :{

205211-- encode $ (mempty :: Schema)

206−-- & type_ .~ SwaggerBoolean

212+-- & type_ ?~ SwaggerBoolean

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

208214-- :}

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

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

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

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

214220--

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

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

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

217223--

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

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

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

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

276282--

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

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

278284-- schema for basic enums like

279285--

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

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

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

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

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

3131import Data.Functor.Identity

32−import Data.Monoid

3332

3433-- | A declare monad transformer parametrized by:

3534--

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

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

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

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

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

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

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

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

5554

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

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

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

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

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

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

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

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

6261

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

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

src/Data/Swagger/Internal.hs+100−12

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

2929import Data.Aeson

3030import qualified Data.Aeson.Types as JSON

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

32+import Data.Hashable (Hashable)

3233import qualified Data.HashMap.Strict as HashMap

34+import Data.HashSet.InsOrd (InsOrdHashSet)

3335import Data.Map (Map)

3436import qualified Data.Map as Map

3537import Data.Monoid (Monoid (..))

36−import Data.Semigroup (Semigroup (..))

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

3739import Data.Scientific (Scientific)

38−import Data.Set (Set)

3940import Data.String (IsString(..))

4041import Data.Text (Text)

4142import qualified Data.Text as Text

4243import GHC.Generics (Generic)

43−import Network (HostName, PortNumber)

44+import Network.Socket (HostName, PortNumber)

4445import Network.HTTP.Media (MediaType)

4546import Text.Read (readMaybe)

4647

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

6566#define DEFINE_TOENCODING

6667#endif

6768

69+-- $setup

70+-- >>> :seti -XDataKinds

71+-- >>> import Data.Aeson

72+

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

6974type Definitions = InsOrdHashMap Text

7075

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

112117 , _swaggerResponses :: Definitions Response

113118

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

115− , _swaggerSecurityDefinitions :: Definitions SecurityScheme

120+ , _swaggerSecurityDefinitions :: SecurityDefinitions

116121

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

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

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

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

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

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

128− , _swaggerTags :: Set Tag

133+ , _swaggerTags :: InsOrdHashSet Tag

129134

130135 -- | Additional external documentation.

131136 , _swaggerExternalDocs :: Maybe ExternalDocs

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

247252data Operation = Operation

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

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

250− _operationTags :: Set TagName

255+ _operationTags :: InsOrdHashSet TagName

251256

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

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

@@ -557,7 +562,7 @@ data Schema = Schema

557562

558563 , _schemaAllOf :: Maybe [Referenced Schema]

559564 , _schemaProperties :: InsOrdHashMap Text (Referenced Schema)

560− , _schemaAdditionalProperties :: Maybe (Referenced Schema)

565+ , _schemaAdditionalProperties :: Maybe AdditionalProperties

561566

562567 , _schemaDiscriminator :: Maybe Text

563568 , _schemaReadOnly :: Maybe Bool

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

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

590595 _paramSchemaDefault :: Maybe Value

591596

592− , _paramSchemaType :: SwaggerType t

597+ , _paramSchemaType :: Maybe (SwaggerType t)

593598 , _paramSchemaFormat :: Maybe Format

594599 , _paramSchemaItems :: Maybe (SwaggerItems t)

595600 , _paramSchemaMaximum :: Maybe Scientific

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

606611 , _paramSchemaMultipleOf :: Maybe Scientific

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

608613

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

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

610615

611616data Xml = Xml

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

@@ -750,6 +755,22 @@ data SecurityScheme = SecurityScheme

750755 , _securitySchemeDescription :: Maybe Text

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

752757

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+

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

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

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

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

774795 , _tagExternalDocs :: Maybe ExternalDocs

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

776797

798+instance Hashable Tag

799+

777800instance IsString Tag where

778801 fromString s = Tag (fromString s) Nothing Nothing

779802

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

787810 , _externalDocsUrl :: URL

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

789812

813+instance Hashable ExternalDocs

814+

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

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

792817newtype Reference = Reference { getReference :: Text }

@@ -800,7 +825,12 @@ data Referenced a

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

801826 fromString = Inline . fromString

802827

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

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

829+

830+data AdditionalProperties

831+ = AdditionalPropertiesAllowed Bool

832+ | AdditionalPropertiesSchema (Referenced Schema)

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

804834

805835-- =======================================================================

806836-- Monoid instances

@@ -890,6 +920,17 @@ instance Monoid Example where

890920 mempty = genericMempty

891921 mappend = (<>)

892922

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+

893934-- =======================================================================

894935-- SwaggerMonoid helper instances

895936-- =======================================================================

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

904945instance SwaggerMonoid Response

905946instance SwaggerMonoid ExternalDocs

906947instance SwaggerMonoid Operation

948+instance SwaggerMonoid SecurityDefinitions

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

907950

908951instance SwaggerMonoid MimeList

909952deriving instance SwaggerMonoid URL

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

10451088 toJSON = sopSwaggerGenericToJSON

10461089 DEFINE_TOENCODING

10471090

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

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

10491098 toJSON (SwaggerItemsPrimitive fmt schema) = object

10501099 [ "collectionFormat" .= fmt

10511100 , "items" .= schema ]

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

1102+ toJSON (SwaggerItemsArray []) = object

1103+ [ "items" .= object []

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

1105+ , "example" .= Array mempty

1106+ ]

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

10541108

10551109instance ToJSON Host where

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

10921146instance ToJSON Example where

10931147 toJSON = toJSON . Map.mapKeys show . getExample

10941148

1149+instance ToJSON SecurityDefinitions where

1150+ toJSON (SecurityDefinitions sd) = toJSON sd

1151+

10951152instance ToJSON Reference where

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

10971154

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

11251182 toJSON = sopSwaggerGenericToJSONWithOpts $

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

11271184

1185+instance ToJSON AdditionalProperties where

1186+ toJSON (AdditionalPropertiesAllowed b) = toJSON b

1187+ toJSON (AdditionalPropertiesSchema s) = toJSON s

1188+

11281189-- =======================================================================

11291190-- Manual FromJSON instances

11301191-- =======================================================================

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

11621223 parseJSON = sopSwaggerGenericParseJSON

11631224

11641225instance FromJSON Schema where

1165− parseJSON = sopSwaggerGenericParseJSON

1226+ parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON

1227+ where nullaryCleanup :: Schema -> Schema

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

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

1230+ then s { _schemaExample = Nothing

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

1232+ else s

11661233

11671234instance FromJSON Header where

11681235 parseJSON = sopSwaggerGenericParseJSON

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

11771244 <$> o .:? "collectionFormat"

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

11791246

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

11801258instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

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

1259+ parseJSON js@(Object obj)

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

1261+ | otherwise = SwaggerItemsObject <$> parseJSON js

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

11831263 parseJSON _ = empty

11841264

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

12301310instance FromJSON PathItem where

12311311 parseJSON = sopSwaggerGenericParseJSON

12321312

1313+instance FromJSON SecurityDefinitions where

1314+ parseJSON js = SecurityDefinitions <$> parseJSON js

1315+

12331316instance FromJSON Reference where

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

12351318 parseJSON _ = empty

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

12801363instance FromJSON (ParamSchema 'SwaggerKindSchema) where

12811364 parseJSON = sopSwaggerGenericParseJSON

12821365

1366+instance FromJSON AdditionalProperties where

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

1368+ parseJSON js = AdditionalPropertiesSchema <$> parseJSON js

1369+

12831370-------------------------------------------------------------------------------

12841371-- TH splices

12851372-------------------------------------------------------------------------------

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

13371424instance AesonDefaultValue MimeList where defaultValue = Just mempty

13381425instance AesonDefaultValue Info

13391426instance AesonDefaultValue ParamLocation

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

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

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

4444import qualified Data.HashMap.Strict as HM

4545import qualified Data.Set as Set

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

47+import qualified Data.HashSet.InsOrd as InsOrdHS

4748

4849#if MIN_VERSION_aeson(0,10,0)

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

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

5151#endif

5252

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

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

6868makeLenses ''SwaggerAesonOptions

6969

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

71− swaggerAesonOptions :: proxy a -> SwaggerAesonOptions

71+ swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

7272

7373 -- So far we use only default definitions

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

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

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

7676

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

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

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

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

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

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

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

9091

9192-------------------------------------------------------------------------------

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

145146 -> DatatypeInfo '[xs]

146147 -> POP Maybe '[xs]

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

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

153+#endif

149154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

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

151156

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

221226 -> DatatypeInfo '[xs]

222227 -> POP Maybe '[xs]

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

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

233+#endif

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

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

227236

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

293302 -> DatatypeInfo '[xs]

294303 -> POP Maybe '[xs]

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

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

309+#endif

297310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

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

299312

src/Data/Swagger/Internal/ParamSchema.hs+39−27

@@ -40,9 +40,10 @@ import qualified Data.Vector.Primitive as VP

4040import qualified Data.Vector.Storable as VS

4141import qualified Data.Vector.Unboxed as VU

4242import Data.Version (Version)

43−import Numeric.Natural

43+import Numeric.Natural.Compat (Natural)

4444import Data.Word

4545import Data.UUID.Types (UUID)

46+import Web.Cookie (SetCookie)

4647

4748import Data.Swagger.Internal

4849import Data.Swagger.Lens

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

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

5960binaryParamSchema :: ParamSchema t

6061binaryParamSchema = mempty

61− & type_ .~ SwaggerString

62+ & type_ ?~ SwaggerString

6263 & format ?~ "binary"

6364

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

6566byteParamSchema :: ParamSchema t

6667byteParamSchema = mempty

67− & type_ .~ SwaggerString

68+ & type_ ?~ SwaggerString

6869 & format ?~ "byte"

6970

7071-- | Default schema for password string.

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

7273passwordParamSchema :: ParamSchema t

7374passwordParamSchema = mempty

74− & type_ .~ SwaggerString

75+ & type_ ?~ SwaggerString

7576 & format ?~ "password"

7677

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

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

8788--

8889-- instance ToParamSchema Direction where

8990-- toParamSchema _ = mempty

90−-- & type_ .~ SwaggerString

91+-- & type_ ?~ SwaggerString

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

9293-- @

9394--

@@ -114,22 +115,22 @@ class ToParamSchema a where

114115 --

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

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

117− toParamSchema :: proxy a -> ParamSchema t

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

118+ toParamSchema :: Proxy a -> ParamSchema t

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

119120 toParamSchema = genericToParamSchema defaultSchemaOptions

120121

121122instance OVERLAPPING_ ToParamSchema String where

122− toParamSchema _ = mempty & type_ .~ SwaggerString

123+ toParamSchema _ = mempty & type_ ?~ SwaggerString

123124

124125instance ToParamSchema Bool where

125− toParamSchema _ = mempty & type_ .~ SwaggerBoolean

126+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

126127

127128instance ToParamSchema Integer where

128− toParamSchema _ = mempty & type_ .~ SwaggerInteger

129+ toParamSchema _ = mempty & type_ ?~ SwaggerInteger

129130

130131instance ToParamSchema Natural where

131132 toParamSchema _ = mempty

132− & type_ .~ SwaggerInteger

133+ & type_ ?~ SwaggerInteger

133134 & minimum_ ?~ 0

134135 & exclusiveMinimum ?~ False

135136

@@ -153,45 +154,51 @@ instance ToParamSchema Word64 where toParamSchema = toParamSchemaBoundedIntegral

153154--

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

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

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

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

157158toParamSchemaBoundedIntegral _ = mempty

158− & type_ .~ SwaggerInteger

159+ & type_ ?~ SwaggerInteger

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

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

161162

162163instance ToParamSchema Char where

163164 toParamSchema _ = mempty

164− & type_ .~ SwaggerString

165+ & type_ ?~ SwaggerString

165166 & maxLength ?~ 1

166167 & minLength ?~ 1

167168

168169instance ToParamSchema Scientific where

169− toParamSchema _ = mempty & type_ .~ SwaggerNumber

170+ toParamSchema _ = mempty & type_ ?~ SwaggerNumber

170171

171172instance HasResolution a => ToParamSchema (Fixed a) where

172173 toParamSchema _ = mempty

173− & type_ .~ SwaggerNumber

174+ & type_ ?~ SwaggerNumber

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

175176

176177instance ToParamSchema Double where

177178 toParamSchema _ = mempty

178− & type_ .~ SwaggerNumber

179+ & type_ ?~ SwaggerNumber

179180 & format ?~ "double"

180181

181182instance ToParamSchema Float where

182183 toParamSchema _ = mempty

183− & type_ .~ SwaggerNumber

184+ & type_ ?~ SwaggerNumber

184185 & format ?~ "float"

185186

186187timeParamSchema :: String -> ParamSchema t

187188timeParamSchema fmt = mempty

188− & type_ .~ SwaggerString

189+ & type_ ?~ SwaggerString

189190 & format ?~ T.pack fmt

190191

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

192193instance ToParamSchema Day where

193194 toParamSchema _ = timeParamSchema "date"

194195

196+-- |

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

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

199+instance ToParamSchema TimeOfDay where

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

201+

195202-- |

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

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

@@ -221,9 +228,14 @@ instance ToParamSchema TL.Text where

221228

222229instance ToParamSchema Version where

223230 toParamSchema _ = mempty

224− & type_ .~ SwaggerString

231+ & type_ ?~ SwaggerString

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

226233

234+instance ToParamSchema SetCookie where

235+ toParamSchema _ = mempty

236+ & type_ ?~ SwaggerString

237+

238+

227239#if __GLASGOW_HASKELL__ < 800

228240#else

229241type family ToParamSchemaByteStringError bs where

@@ -248,7 +260,7 @@ instance ToParamSchema a => ToParamSchema (Identity a) where toParamSchema _ = t

248260

249261instance ToParamSchema a => ToParamSchema [a] where

250262 toParamSchema _ = mempty

251− & type_ .~ SwaggerArray

263+ & type_ ?~ SwaggerArray

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

253265

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

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

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

269281instance ToParamSchema () where

270282 toParamSchema _ = mempty

271− & type_ .~ SwaggerString

283+ & type_ ?~ SwaggerString

272284 & enum_ ?~ ["_"]

273285

274286instance ToParamSchema UUID where

275287 toParamSchema _ = mempty

276− & type_ .~ SwaggerString

288+ & type_ ?~ SwaggerString

277289 & format ?~ "uuid"

278290

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

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

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

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

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

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

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

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

287299

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

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

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

290302

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

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

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

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

305317

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

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

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

308320

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

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

311323

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

313325 genumParamSchema opts _ s = s

314− & type_ .~ SwaggerString

326+ & type_ ?~ SwaggerString

315327 & enum_ %~ addEnumValue tag

316328 where

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

src/Data/Swagger/Internal/Schema.hs+82−73

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

3232

3333import Control.Monad

3434import Control.Monad.Writer

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

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

3636import Data.Char

3737import Data.Data (Data)

3838import Data.Foldable (traverse_)

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

4444import Data.Int

4545import Data.IntSet (IntSet)

4646import Data.IntMap (IntMap)

47−import Data.List.NonEmpty (NonEmpty)

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

4848import Data.Map (Map)

4949import Data.Proxy

5050import Data.Scientific (Scientific)

@@ -58,7 +58,7 @@ import qualified Data.Vector.Primitive as VP

5858import qualified Data.Vector.Storable as VS

5959import qualified Data.Vector.Unboxed as VU

6060import Data.Version (Version)

61−import Numeric.Natural

61+import Numeric.Natural.Compat (Natural)

6262import Data.Word

6363import GHC.Generics

6464import qualified Data.UUID.Types as UUID

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

111111-- declareNamedSchema _ = do

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

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

114−-- & type_ .~ SwaggerObject

114+-- & type_ ?~ SwaggerObject

115115-- & properties .~

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

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

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

142142 -- together with all used definitions.

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

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

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

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

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

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

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

148148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

149149

150+instance ToSchema TimeOfDay where

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

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

153+

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

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

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

152156declareSchema = fmap _namedSchemaSchema . declareNamedSchema

153157

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

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

162166-- Just "Day"

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

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

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

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

166170toNamedSchema = undeclare . declareNamedSchema

167171

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

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

172176--

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

174178-- Just "UTCTime"

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

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

176180schemaName = _namedSchemaName . toNamedSchema

177181

178182-- | Convert a type into a schema.

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

182186--

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

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

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

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

186190toSchema = _namedSchemaSchema . toNamedSchema

187191

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

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

193197--

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

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

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

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

197201toSchemaRef = undeclare . declareSchemaRef

198202

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

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

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

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

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

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

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

207211declareSchemaRef proxy = do

208212 case toNamedSchema proxy of

209213 NamedSchema (Just name) schema -> do

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

265269--

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

267271-- when inlining recursive schemas.

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

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

269273toInlinedSchema proxy = inlineAllSchemas defs schema

270274 where

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

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

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

295299binarySchema :: Schema

296300binarySchema = mempty

297− & type_ .~ SwaggerString

301+ & type_ ?~ SwaggerString

298302 & format ?~ "binary"

299303

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

301305byteSchema :: Schema

302306byteSchema = mempty

303− & type_ .~ SwaggerString

307+ & type_ ?~ SwaggerString

304308 & format ?~ "byte"

305309

306310-- | Default schema for password string.

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

308312passwordSchema :: Schema

309313passwordSchema = mempty

310− & type_ .~ SwaggerString

314+ & type_ ?~ SwaggerString

311315 & format ?~ "password"

312316

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

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

333337 sketch js@(Bool _) = go js

334338 sketch js = go js & example ?~ js

335339

336− go Null = mempty & type_ .~ SwaggerNull

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

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

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

340+ go Null = mempty & type_ ?~ SwaggerNull

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

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

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

340344 go (Array xs) = mempty

341− & type_ .~ SwaggerArray

345+ & type_ ?~ SwaggerArray

342346 & items ?~ case ischema of

343347 Just s -> SwaggerItemsObject (Inline s)

344348 _ -> SwaggerItemsArray (map Inline ys)

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

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

351355 _ -> Nothing

352356 go (Object o) = mempty

353− & type_ .~ SwaggerObject

357+ & type_ ?~ SwaggerObject

354358 & required .~ HashMap.keys o

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

356360

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

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

374378sketchStrictSchema = go . toJSON

375379 where

376− go Null = mempty & type_ .~ SwaggerNull

380+ go Null = mempty & type_ ?~ SwaggerNull

377381 go js@(Bool _) = mempty

378− & type_ .~ SwaggerBoolean

382+ & type_ ?~ SwaggerBoolean

379383 & enum_ ?~ [js]

380384 go js@(String s) = mempty

381− & type_ .~ SwaggerString

385+ & type_ ?~ SwaggerString

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

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

384388 & pattern ?~ s

385389 & enum_ ?~ [js]

386390 go js@(Number n) = mempty

387− & type_ .~ SwaggerNumber

391+ & type_ ?~ SwaggerNumber

388392 & maximum_ ?~ n

389393 & minimum_ ?~ n

390394 & multipleOf ?~ n

391395 & enum_ ?~ [js]

392396 go js@(Array xs) = mempty

393− & type_ .~ SwaggerArray

397+ & type_ ?~ SwaggerArray

394398 & maxItems ?~ fromIntegral sz

395399 & minItems ?~ fromIntegral sz

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

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

400404 sz = length xs

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

402406 go js@(Object o) = mempty

403− & type_ .~ SwaggerObject

407+ & type_ ?~ SwaggerObject

404408 & required .~ names

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

406410 & maxProperties ?~ fromIntegral (length names)

@@ -410,13 +414,13 @@ sketchStrictSchema = go . toJSON

410414 names = HashMap.keys o

411415

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

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

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

414418

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

416420 declareNamedSchema _ = do

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

418422 return $ unnamed $ mempty

419− & type_ .~ SwaggerArray

423+ & type_ ?~ SwaggerArray

420424 & items ?~ SwaggerItemsObject ref

421425

422426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

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

466470

467471timeSchema :: T.Text -> Schema

468472timeSchema fmt = mempty

469− & type_ .~ SwaggerString

473+ & type_ ?~ SwaggerString

470474 & format ?~ fmt

471475

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

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

528532 declareObjectMapSchema = do

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

530534 return $ unnamed $ mempty

531− & type_ .~ SwaggerObject

532− & additionalProperties ?~ schema

535+ & type_ ?~ SwaggerObject

536+ & additionalProperties ?~ AdditionalPropertiesSchema schema

533537

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

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

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

540544 declareNamedSchema _ = do

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

542546 return $ unnamed $ mempty

543− & type_ .~ SwaggerObject

547+ & type_ ?~ SwaggerObject

544548 & additionalProperties ?~ schema

545549

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

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

552556

553557#endif

554558

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+

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

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

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

@@ -587,26 +597,26 @@ instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declar

587597--

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

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

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

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

591601toSchemaBoundedIntegral _ = mempty

592− & type_ .~ SwaggerInteger

602+ & type_ ?~ SwaggerInteger

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

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

595605

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

597−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

607+genericToNamedSchemaBoundedIntegral :: forall a d f.

598608 ( Bounded a, Integral a

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

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

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

601611genericToNamedSchemaBoundedIntegral opts proxy

602612 = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

603613

604614-- | Declare a named schema for a @newtype@ wrapper.

605−genericDeclareNamedSchemaNewtype :: forall proxy a d c s i inner.

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

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

607617 => SchemaOptions -- ^ How to derive the name.

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

609− -> proxy a

619+ -> Proxy a

610620 -> Declare (Definitions Schema) NamedSchema

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

612622

@@ -623,9 +633,9 @@ genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$>

623633--

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

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

626−declareSchemaBoundedEnumKeyMapping :: forall map key value proxy.

636+declareSchemaBoundedEnumKeyMapping :: forall map key value.

627637 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

628− => proxy (map key value) -> Declare (Definitions Schema) Schema

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

629639declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

630640 ToJSONKeyText keyToText _ -> objectSchema keyToText

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

@@ -635,7 +645,7 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o

635645 let allKeys = [minBound..maxBound :: key]

636646 mkPair k = (keyToText k, valueRef)

637647 return $ mempty

638− & type_ .~ SwaggerObject

648+ & type_ ?~ SwaggerObject

639649 & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)

640650

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

@@ -651,46 +661,46 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o

651661--

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

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

654−toSchemaBoundedEnumKeyMapping :: forall map key value proxy.

664+toSchemaBoundedEnumKeyMapping :: forall map key value.

655665 (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)

656− => proxy (map key value) -> Schema

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

657667toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

658668

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

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

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

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

662672genericDeclareSchema = genericDeclareSchemaUnrestricted

663673

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

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

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

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

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

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

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

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

670680genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

671681

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

673683--

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

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

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

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

677687genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy

678688

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

680690--

681691-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.

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

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

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

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

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

685695genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

686696

687697-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.

688−genericNameSchema :: forall a d f proxy.

698+genericNameSchema :: forall a d f.

689699 (Generic a, Rep a ~ D1 d f, Datatype d)

690− => SchemaOptions -> proxy a -> Schema -> NamedSchema

700+ => SchemaOptions -> Proxy a -> Schema -> NamedSchema

691701genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))

692702

693−gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text

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

694704gdatatypeSchemaName opts _ = case orig of

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

696706 _ -> Nothing

@@ -699,24 +709,23 @@ gdatatypeSchemaName opts _ = case orig of

699709 name = datatypeNameModifier opts orig

700710

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

702−paramSchemaToNamedSchema :: forall a d f proxy.

703− (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d)

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

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

713+ SchemaOptions -> Proxy a -> NamedSchema

705714paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)

706715

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

708−paramSchemaToSchema :: forall a proxy. ToParamSchema a => proxy a -> Schema

709−paramSchemaToSchema _ = mempty & paramSchema .~ toParamSchema (Proxy :: Proxy a)

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

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

710719

711720nullarySchema :: Schema

712721nullarySchema = mempty

713− & type_ .~ SwaggerArray

722+ & type_ ?~ SwaggerArray

714723 & items ?~ SwaggerItemsArray []

715724

716−gtoNamedSchema :: GToSchema f => SchemaOptions -> proxy f -> NamedSchema

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

717726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

718727

719−gdeclareSchema :: GToSchema f => SchemaOptions -> proxy f -> Declare (Definitions Schema) Schema

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

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

721730

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

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

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

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

752761

753−gdeclareSchemaRef :: GToSchema a => SchemaOptions -> proxy a -> Declare (Definitions Schema) (Referenced Schema)

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

754763gdeclareSchemaRef opts proxy = do

755764 case gtoNamedSchema opts proxy of

756765 NamedSchema (Just name) schema -> do

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

781790 return $

782791 if T.null fname

783792 then schema

784− & type_ .~ SwaggerArray

793+ & type_ ?~ SwaggerArray

785794 & items %~ appendItem ref

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

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

788797 else schema

789− & type_ .~ SwaggerObject

798+ & type_ ?~ SwaggerObject

790799 & properties . at fname ?~ ref

791800 & if isRequiredField

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

@@ -814,7 +823,7 @@ instance ( GSumToSchema f

814823 where

815824 gdeclareNamedSchema = gdeclareNamedSumSchema

816825

817−gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

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

818827gdeclareNamedSumSchema opts proxy s

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

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

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

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

824833

825834 toStringTag schema = mempty

826− & type_ .~ SwaggerString

835+ & type_ ?~ SwaggerString

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

828837

829838type AllNullary = All

830839

831840class GSumToSchema (f :: * -> *) where

832− gsumToSchema :: SchemaOptions -> proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

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

833842

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

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

836845

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

838− Referenced Schema -> SchemaOptions -> proxy (C1 c f) -> Schema -> Schema

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

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

839848gsumConToSchemaWith ref opts _ schema = schema

840− & type_ .~ SwaggerObject

849+ & type_ ?~ SwaggerObject

841850 & properties . at tag ?~ ref

842851 & maxProperties ?~ 1

843852 & minProperties ?~ 1

844853 where

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

846855

847−gsumConToSchema :: forall c f proxy. (GToSchema (C1 c f), Constructor c) =>

848− SchemaOptions -> proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema

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

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

849858gsumConToSchema opts proxy schema = do

850859 ref <- gdeclareSchemaRef opts proxy

851860 return $ gsumConToSchemaWith ref opts proxy schema

src/Data/Swagger/Internal/Schema/Validation.hs+212−50

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

1−{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE GADTs #-}

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE GADTs #-}

57{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE PackageImports #-}

9−{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TemplateHaskell #-}

12−{-# LANGUAGE UndecidableInstances #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PackageImports #-}

11+{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TemplateHaskell #-}

14+{-# LANGUAGE UndecidableInstances #-}

1315-- |

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

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

2022-- Validate JSON values with Swagger Schema.

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

2224

23−import Control.Applicative

24−import Control.Lens

25−import Control.Monad (when)

25+import Prelude ()

26+import Prelude.Compat

2627

27−import Data.Aeson hiding (Result)

28−import Data.Foldable (traverse_, for_, sequenceA_)

29−import Data.HashMap.Strict (HashMap)

30−import qualified Data.HashMap.Strict as HashMap

28+import Control.Applicative

29+import Control.Lens

30+import Control.Monad (when)

31+

32+import Data.Aeson hiding (Result)

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

34+import Data.Foldable (for_, sequenceA_,

35+ traverse_)

36+import Data.HashMap.Strict (HashMap)

37+import qualified Data.HashMap.Strict as HashMap

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

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

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

33−import Data.Monoid

34−import Data.Proxy

35−import Data.Scientific (Scientific, isInteger)

36−import Data.Text (Text)

37−import qualified Data.Text as Text

38−import Data.Vector (Vector)

39−import qualified Data.Vector as Vector

40−

41−import Data.Swagger.Declare

42−import Data.Swagger.Internal

43−import Data.Swagger.Internal.Schema

44−import Data.Swagger.Lens

40+import Data.Proxy

41+import Data.Scientific (Scientific, isInteger)

42+import Data.Text (Text)

43+import qualified Data.Text as Text

44+import qualified Data.Text.Lazy as TL

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

46+import Data.Vector (Vector)

47+import qualified Data.Vector as Vector

48+

49+import Data.Swagger.Declare

50+import Data.Swagger.Internal

51+import Data.Swagger.Internal.Schema

52+import Data.Swagger.Lens

4553

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

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

@@ -50,18 +58,101 @@ import Data.Swagger.Lens

5058--

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

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

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

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

5569

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

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

5872--

59−-- For validation without patterns see @'validateToJSON'@.

73+-- For validation without patterns see @'validateToJSON'@. See also:

74+-- 'renderValidationErrors'.

6075validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]

6176validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

6277 where

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

6479

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+

65156-- | Validate JSON @'Value'@ against Swagger @'Schema'@.

66157--

67158-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []

@@ -312,12 +403,16 @@ validateObject o = withSchema $ \sch ->

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

313404 _ ->

314405 case InsOrdHashMap.lookup k (sch ^. properties) of

315− Nothing -> checkMissing (unknownProperty k) additionalProperties $ \s -> validateWithSchemaRef s v

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

316407 Just s -> validateWithSchemaRef s v

317408

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+

318413 unknownProperty :: Text -> Validation s a

319− unknownProperty name = invalid $

320− "property " <> show name <> " is found in JSON value, but it is not mentioned in Swagger schema"

414+ unknownProperty pname = invalid $

415+ "property " <> show pname <> " is found in JSON value, but it is not mentioned in Swagger schema"

321416

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

323418validateEnum value = do

@@ -325,25 +420,92 @@ validateEnum value = do

325420 when (value `notElem` xs) $

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

327422

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+

328470validateSchemaType :: Value -> Validation Schema ()

329471validateSchemaType value = withSchema $ \sch ->

330472 case (sch ^. type_, value) of

331− (SwaggerNull, Null) -> valid

332− (SwaggerBoolean, Bool _) -> valid

333− (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

334− (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

335− (SwaggerString, String s) -> sub_ paramSchema (validateString s)

336− (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

337− (SwaggerObject, Object o) -> validateObject o

338− (t, _) -> invalid $ "expected JSON value of type " ++ show t

473+ (Just SwaggerNull, Null) -> valid

474+ (Just SwaggerBoolean, Bool _) -> valid

475+ (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)

476+ (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)

477+ (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)

478+ (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

479+ (Just SwaggerObject, Object o) -> validateObject o

480+ (Nothing, Null) -> valid

481+ (Nothing, Bool _) -> valid

482+ -- Number by default

483+ (Nothing, Number n) -> sub_ paramSchema (validateNumber n)

484+ (Nothing, String s) -> sub_ paramSchema (validateString s)

485+ (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)

486+ (Nothing, Object o) -> validateObject o

487+ bad -> invalid $ "expected JSON value of type " ++ showType bad

339488

340489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()

341490validateParamSchemaType value = withSchema $ \sch ->

342491 case (sch ^. type_, value) of

343− (SwaggerBoolean, Bool _) -> valid

344− (SwaggerInteger, Number n) -> validateInteger n

345− (SwaggerNumber, Number n) -> validateNumber n

346− (SwaggerString, String s) -> validateString s

347− (SwaggerArray, Array xs) -> validateArray xs

348− (t, _) -> invalid $ "expected JSON value of type " ++ show t

349−

492+ (Just SwaggerBoolean, Bool _) -> valid

493+ (Just SwaggerInteger, Number n) -> validateInteger n

494+ (Just SwaggerNumber, Number n) -> validateNumber n

495+ (Just SwaggerString, String s) -> validateString s

496+ (Just SwaggerArray, Array xs) -> validateArray xs

497+ (Nothing, Bool _) -> valid

498+ -- Number by default

499+ (Nothing, Number n) -> validateNumber n

500+ (Nothing, String s) -> validateString s

501+ (Nothing, Array xs) -> validateArray xs

502+ bad -> invalid $ "expected JSON value of type " ++ showType bad

503+

504+showType :: (Maybe (SwaggerType t), Value) -> String

505+showType (Just type_, _) = show type_

506+showType (Nothing, Null) = "SwaggerNull"

507+showType (Nothing, Bool _) = "SwaggerBoolean"

508+showType (Nothing, Number _) = "SwaggerNumber"

509+showType (Nothing, String _) = "SwaggerString"

510+showType (Nothing, Array _) = "SwaggerArray"

511+showType (Nothing, Object _) = "SwaggerObject"

src/Data/Swagger/Internal/Utils.hs−1

@@ -21,7 +21,6 @@ import qualified Data.HashMap.Strict as HashMap

2121import Data.HashMap.Strict.InsOrd (InsOrdHashMap)

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

2323import Data.Map (Map)

24−import Data.Monoid

2524import Data.Set (Set)

2625import Data.Text (Text)

2726import GHC.Generics

src/Data/Swagger/Lens.hs+10−4

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

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

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

9898

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+

99105instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema

100106

101107-- HasType instances

102−instance HasType Header (SwaggerType ('SwaggerKindNormal Header)) where type_ = paramSchema.type_

103−instance HasType Schema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

104−instance HasType NamedSchema (SwaggerType 'SwaggerKindSchema) where type_ = paramSchema.type_

105−instance HasType ParamOtherSchema (SwaggerType 'SwaggerKindParamOtherSchema) where type_ = paramSchema.type_

108+instance HasType Header (Maybe (SwaggerType ('SwaggerKindNormal Header))) where type_ = paramSchema.type_

109+instance HasType Schema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

110+instance HasType NamedSchema (Maybe (SwaggerType 'SwaggerKindSchema)) where type_ = paramSchema.type_

111+instance HasType ParamOtherSchema (Maybe (SwaggerType 'SwaggerKindParamOtherSchema)) where type_ = paramSchema.type_

106112

107113-- HasDefault instances

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

src/Data/Swagger/Operation.hs+5−5

@@ -37,7 +37,7 @@ import Control.Lens

3737import Data.Data.Lens

3838import Data.List.Compat

3939import Data.Maybe (mapMaybe)

40−import Data.Monoid

40+import Data.Proxy

4141import qualified Data.Set as Set

4242

4343import Data.Swagger.Declare

@@ -46,6 +46,7 @@ import Data.Swagger.Lens

4646import Data.Swagger.Schema

4747

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

49+import qualified Data.HashSet.InsOrd as InsOrdHS

4950

5051-- $setup

5152-- >>> import Data.Aeson

@@ -111,15 +112,15 @@ applyTags = applyTagsFor allOperations

111112-- list of tags.

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

113114applyTagsFor ops ts swag = swag

114− & ops . tags %~ (<> Set.fromList (map _tagName ts))

115− & tags %~ (<> Set.fromList ts)

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

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

116117

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

118119-- necessary schema definitions.

119120--

120121-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty

121122-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"

122−declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response

123+declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response

123124declareResponse proxy = do

124125 s <- declareSchemaRef proxy

125126 return (mempty & schema ?~ s)

@@ -190,4 +191,3 @@ setResponseForWith ops f code dres swag = swag

190191 Nothing -> new -- response name can't be dereferenced, replacing with new response

191192 combine (Just (Inline old)) = f old new

192193 combine Nothing = new

193−

src/Data/Swagger/Optics.hsnew file+597

@@ -0,0 +1,597 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE OverloadedLabels #-}

5+{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE UndecidableInstances #-}

8+{-# OPTIONS_GHC -fno-warn-orphans #-}

9+-- |

10+-- Module: Data.Swagger.Optics

11+-- Maintainer: Andrzej Rybczak <andrzej@rybczak.net>

12+-- Stability: experimental

13+--

14+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>

15+-- library.

16+--

17+-- >>> import Data.Aeson

18+-- >>> import Optics.Core

19+-- >>> :set -XOverloadedLabels

20+--

21+-- Example from the "Data.Swagger" module using @optics@:

22+--

23+-- >>> :{

24+-- encode $ (mempty :: Swagger)

25+-- & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]

26+-- & #paths .~

27+-- [ ("/user", mempty & #get ?~ (mempty

28+-- & #produces ?~ MimeList ["application/json"]

29+-- & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))

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

31+-- :}

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

33+--

34+-- For convenience optics are defined as /labels/. It means that field accessor

35+-- names can be overloaded for different types. One such common field is

36+-- @#description@. Many components of a Swagger specification can have

37+-- descriptions, and you can use the same name for them:

38+--

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

40+-- "{\"description\":\"No content\"}"

41+-- >>> :{

42+-- encode $ (mempty :: Schema)

43+-- & #type ?~ SwaggerBoolean

44+-- & #description ?~ "To be or not to be"

45+-- :}

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

47+--

48+-- @'ParamSchema'@ is basically the /base schema specification/ and many types

49+-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively

50+-- made fields of the type that has it. For example, you can use @#type@ to

51+-- access @'SwaggerType'@ of @'Header'@ schema without having to use

52+-- @#paramSchema@:

53+--

54+-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber

55+-- "{\"type\":\"number\"}"

56+--

57+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and

58+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:

59+--

60+-- >>> :{

61+-- encode $ (mempty :: Operation)

62+-- & at 404 ?~ "Not found"

63+-- :}

64+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"

65+--

66+module Data.Swagger.Optics () where

67+

68+import Data.Aeson (Value)

69+import Data.Scientific (Scientific)

70+import Data.Swagger.Internal

71+import Data.Text (Text)

72+import Optics.Core

73+import Optics.TH

74+

75+-- Lenses

76+

77+makeFieldLabels ''Swagger

78+makeFieldLabels ''Host

79+makeFieldLabels ''Info

80+makeFieldLabels ''Contact

81+makeFieldLabels ''License

82+makeFieldLabels ''PathItem

83+makeFieldLabels ''Tag

84+makeFieldLabels ''Operation

85+makeFieldLabels ''Param

86+makeFieldLabels ''ParamOtherSchema

87+makeFieldLabels ''Header

88+makeFieldLabels ''Schema

89+makeFieldLabels ''NamedSchema

90+makeFieldLabels ''ParamSchema

91+makeFieldLabels ''Xml

92+makeFieldLabels ''Responses

93+makeFieldLabels ''Response

94+makeFieldLabels ''SecurityScheme

95+makeFieldLabels ''ApiKeyParams

96+makeFieldLabels ''OAuth2Params

97+makeFieldLabels ''ExternalDocs

98+

99+-- Prisms

100+

101+makePrismLabels ''ParamAnySchema

102+makePrismLabels ''SecuritySchemeType

103+makePrismLabels ''Referenced

104+

105+-- SwaggerItems prisms

106+

107+instance

108+ ( a ~ [Referenced Schema]

109+ , b ~ [Referenced Schema]

110+ ) => LabelOptic "_SwaggerItemsArray"

111+ A_Review

112+ (SwaggerItems 'SwaggerKindSchema)

113+ (SwaggerItems 'SwaggerKindSchema)

114+ a

115+ b where

116+ labelOptic = unto (\x -> SwaggerItemsArray x)

117+ {-# INLINE labelOptic #-}

118+

119+instance

120+ ( a ~ Referenced Schema

121+ , b ~ Referenced Schema

122+ ) => LabelOptic "_SwaggerItemsObject"

123+ A_Review

124+ (SwaggerItems 'SwaggerKindSchema)

125+ (SwaggerItems 'SwaggerKindSchema)

126+ a

127+ b where

128+ labelOptic = unto (\x -> SwaggerItemsObject x)

129+ {-# INLINE labelOptic #-}

130+

131+instance

132+ ( a ~ (Maybe (CollectionFormat t), ParamSchema t)

133+ , b ~ (Maybe (CollectionFormat t), ParamSchema t)

134+ ) => LabelOptic "_SwaggerItemsPrimitive"

135+ A_Review

136+ (SwaggerItems t)

137+ (SwaggerItems t)

138+ a

139+ b where

140+ labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)

141+ {-# INLINE labelOptic #-}

142+

143+-- =============================================================

144+-- More helpful instances for easier access to schema properties

145+

146+type instance Index Responses = HttpStatusCode

147+type instance Index Operation = HttpStatusCode

148+

149+type instance IxValue Responses = Referenced Response

150+type instance IxValue Operation = Referenced Response

151+

152+instance Ixed Responses where

153+ ix n = #responses % ix n

154+ {-# INLINE ix #-}

155+instance At Responses where

156+ at n = #responses % at n

157+ {-# INLINE at #-}

158+

159+instance Ixed Operation where

160+ ix n = #responses % ix n

161+ {-# INLINE ix #-}

162+instance At Operation where

163+ at n = #responses % at n

164+ {-# INLINE at #-}

165+

166+-- #paramSchema

167+

168+instance

169+ ( a ~ ParamSchema 'SwaggerKindSchema

170+ , b ~ ParamSchema 'SwaggerKindSchema

171+ ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where

172+ labelOptic = #schema % #paramSchema

173+ {-# INLINE labelOptic #-}

174+

175+-- #type

176+

177+instance

178+ ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

179+ , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))

180+ ) => LabelOptic "type" A_Lens Header Header a b where

181+ labelOptic = #paramSchema % #type

182+ {-# INLINE labelOptic #-}

183+

184+instance

185+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

186+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

187+ ) => LabelOptic "type" A_Lens Schema Schema a b where

188+ labelOptic = #paramSchema % #type

189+ {-# INLINE labelOptic #-}

190+

191+instance

192+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

193+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

194+ ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where

195+ labelOptic = #paramSchema % #type

196+ {-# INLINE labelOptic #-}

197+

198+instance

199+ ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

200+ , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

201+ ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where

202+ labelOptic = #paramSchema % #type

203+ {-# INLINE labelOptic #-}

204+

205+-- #default

206+

207+instance

208+ ( a ~ Maybe Value, b ~ Maybe Value

209+ ) => LabelOptic "default" A_Lens Header Header a b where

210+ labelOptic = #paramSchema % #default

211+ {-# INLINE labelOptic #-}

212+

213+instance

214+ ( a ~ Maybe Value, b ~ Maybe Value

215+ ) => LabelOptic "default" A_Lens Schema Schema a b where

216+ labelOptic = #paramSchema % #default

217+ {-# INLINE labelOptic #-}

218+

219+instance

220+ ( a ~ Maybe Value, b ~ Maybe Value

221+ ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where

222+ labelOptic = #paramSchema % #default

223+ {-# INLINE labelOptic #-}

224+

225+instance

226+ ( a ~ Maybe Value, b ~ Maybe Value

227+ ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where

228+ labelOptic = #paramSchema % #default

229+ {-# INLINE labelOptic #-}

230+

231+-- #format

232+

233+instance

234+ ( a ~ Maybe Format, b ~ Maybe Format

235+ ) => LabelOptic "format" A_Lens Header Header a b where

236+ labelOptic = #paramSchema % #format

237+ {-# INLINE labelOptic #-}

238+

239+instance

240+ ( a ~ Maybe Format, b ~ Maybe Format

241+ ) => LabelOptic "format" A_Lens Schema Schema a b where

242+ labelOptic = #paramSchema % #format

243+ {-# INLINE labelOptic #-}

244+

245+instance

246+ ( a ~ Maybe Format, b ~ Maybe Format

247+ ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where

248+ labelOptic = #paramSchema % #format

249+ {-# INLINE labelOptic #-}

250+

251+instance

252+ ( a ~ Maybe Format, b ~ Maybe Format

253+ ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where

254+ labelOptic = #paramSchema % #format

255+ {-# INLINE labelOptic #-}

256+

257+-- #items

258+

259+instance

260+ ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

261+ , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))

262+ ) => LabelOptic "items" A_Lens Header Header a b where

263+ labelOptic = #paramSchema % #items

264+ {-# INLINE labelOptic #-}

265+

266+instance

267+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

268+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

269+ ) => LabelOptic "items" A_Lens Schema Schema a b where

270+ labelOptic = #paramSchema % #items

271+ {-# INLINE labelOptic #-}

272+

273+instance

274+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

275+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

276+ ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where

277+ labelOptic = #paramSchema % #items

278+ {-# INLINE labelOptic #-}

279+

280+instance

281+ ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

282+ , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

283+ ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where

284+ labelOptic = #paramSchema % #items

285+ {-# INLINE labelOptic #-}

286+

287+-- #maximum

288+

289+instance

290+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

291+ ) => LabelOptic "maximum" A_Lens Header Header a b where

292+ labelOptic = #paramSchema % #maximum

293+ {-# INLINE labelOptic #-}

294+

295+instance

296+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

297+ ) => LabelOptic "maximum" A_Lens Schema Schema a b where

298+ labelOptic = #paramSchema % #maximum

299+ {-# INLINE labelOptic #-}

300+

301+instance

302+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

303+ ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where

304+ labelOptic = #paramSchema % #maximum

305+ {-# INLINE labelOptic #-}

306+

307+instance

308+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

309+ ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

310+ labelOptic = #paramSchema % #maximum

311+ {-# INLINE labelOptic #-}

312+

313+-- #exclusiveMaximum

314+

315+instance

316+ ( a ~ Maybe Bool, b ~ Maybe Bool

317+ ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where

318+ labelOptic = #paramSchema % #exclusiveMaximum

319+ {-# INLINE labelOptic #-}

320+

321+instance

322+ ( a ~ Maybe Bool, b ~ Maybe Bool

323+ ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where

324+ labelOptic = #paramSchema % #exclusiveMaximum

325+ {-# INLINE labelOptic #-}

326+

327+instance

328+ ( a ~ Maybe Bool, b ~ Maybe Bool

329+ ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where

330+ labelOptic = #paramSchema % #exclusiveMaximum

331+ {-# INLINE labelOptic #-}

332+

333+instance

334+ ( a ~ Maybe Bool, b ~ Maybe Bool

335+ ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where

336+ labelOptic = #paramSchema % #exclusiveMaximum

337+ {-# INLINE labelOptic #-}

338+

339+-- #minimum

340+

341+instance

342+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

343+ ) => LabelOptic "minimum" A_Lens Header Header a b where

344+ labelOptic = #paramSchema % #minimum

345+ {-# INLINE labelOptic #-}

346+

347+instance

348+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

349+ ) => LabelOptic "minimum" A_Lens Schema Schema a b where

350+ labelOptic = #paramSchema % #minimum

351+ {-# INLINE labelOptic #-}

352+

353+instance

354+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

355+ ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where

356+ labelOptic = #paramSchema % #minimum

357+ {-# INLINE labelOptic #-}

358+

359+instance

360+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

361+ ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

362+ labelOptic = #paramSchema % #minimum

363+ {-# INLINE labelOptic #-}

364+

365+-- #exclusiveMinimum

366+

367+instance

368+ ( a ~ Maybe Bool, b ~ Maybe Bool

369+ ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where

370+ labelOptic = #paramSchema % #exclusiveMinimum

371+ {-# INLINE labelOptic #-}

372+

373+instance

374+ ( a ~ Maybe Bool, b ~ Maybe Bool

375+ ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where

376+ labelOptic = #paramSchema % #exclusiveMinimum

377+ {-# INLINE labelOptic #-}

378+

379+instance

380+ ( a ~ Maybe Bool, b ~ Maybe Bool

381+ ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where

382+ labelOptic = #paramSchema % #exclusiveMinimum

383+ {-# INLINE labelOptic #-}

384+

385+instance

386+ ( a ~ Maybe Bool, b ~ Maybe Bool

387+ ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

388+ labelOptic = #paramSchema % #exclusiveMinimum

389+ {-# INLINE labelOptic #-}

390+

391+-- #maxLength

392+

393+instance

394+ ( a ~ Maybe Integer, b ~ Maybe Integer

395+ ) => LabelOptic "maxLength" A_Lens Header Header a b where

396+ labelOptic = #paramSchema % #maxLength

397+ {-# INLINE labelOptic #-}

398+

399+instance

400+ ( a ~ Maybe Integer, b ~ Maybe Integer

401+ ) => LabelOptic "maxLength" A_Lens Schema Schema a b where

402+ labelOptic = #paramSchema % #maxLength

403+ {-# INLINE labelOptic #-}

404+

405+instance

406+ ( a ~ Maybe Integer, b ~ Maybe Integer

407+ ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where

408+ labelOptic = #paramSchema % #maxLength

409+ {-# INLINE labelOptic #-}

410+

411+instance

412+ ( a ~ Maybe Integer, b ~ Maybe Integer

413+ ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

414+ labelOptic = #paramSchema % #maxLength

415+ {-# INLINE labelOptic #-}

416+

417+-- #minLength

418+

419+instance

420+ ( a ~ Maybe Integer, b ~ Maybe Integer

421+ ) => LabelOptic "minLength" A_Lens Header Header a b where

422+ labelOptic = #paramSchema % #minLength

423+ {-# INLINE labelOptic #-}

424+

425+instance

426+ ( a ~ Maybe Integer, b ~ Maybe Integer

427+ ) => LabelOptic "minLength" A_Lens Schema Schema a b where

428+ labelOptic = #paramSchema % #minLength

429+ {-# INLINE labelOptic #-}

430+

431+instance

432+ ( a ~ Maybe Integer, b ~ Maybe Integer

433+ ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where

434+ labelOptic = #paramSchema % #minLength

435+ {-# INLINE labelOptic #-}

436+

437+instance

438+ ( a ~ Maybe Integer, b ~ Maybe Integer

439+ ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

440+ labelOptic = #paramSchema % #minLength

441+ {-# INLINE labelOptic #-}

442+

443+-- #pattern

444+

445+instance

446+ ( a ~ Maybe Text, b ~ Maybe Text

447+ ) => LabelOptic "pattern" A_Lens Header Header a b where

448+ labelOptic = #paramSchema % #pattern

449+ {-# INLINE labelOptic #-}

450+

451+instance

452+ ( a ~ Maybe Text, b ~ Maybe Text

453+ ) => LabelOptic "pattern" A_Lens Schema Schema a b where

454+ labelOptic = #paramSchema % #pattern

455+ {-# INLINE labelOptic #-}

456+

457+instance

458+ ( a ~ Maybe Text, b ~ Maybe Text

459+ ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where

460+ labelOptic = #paramSchema % #pattern

461+ {-# INLINE labelOptic #-}

462+

463+instance

464+ ( a ~ Maybe Text, b ~ Maybe Text

465+ ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where

466+ labelOptic = #paramSchema % #pattern

467+ {-# INLINE labelOptic #-}

468+

469+-- #maxItems

470+

471+instance

472+ ( a ~ Maybe Integer, b ~ Maybe Integer

473+ ) => LabelOptic "maxItems" A_Lens Header Header a b where

474+ labelOptic = #paramSchema % #maxItems

475+ {-# INLINE labelOptic #-}

476+

477+instance

478+ ( a ~ Maybe Integer, b ~ Maybe Integer

479+ ) => LabelOptic "maxItems" A_Lens Schema Schema a b where

480+ labelOptic = #paramSchema % #maxItems

481+ {-# INLINE labelOptic #-}

482+

483+instance

484+ ( a ~ Maybe Integer, b ~ Maybe Integer

485+ ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where

486+ labelOptic = #paramSchema % #maxItems

487+ {-# INLINE labelOptic #-}

488+

489+instance

490+ ( a ~ Maybe Integer, b ~ Maybe Integer

491+ ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

492+ labelOptic = #paramSchema % #maxItems

493+ {-# INLINE labelOptic #-}

494+

495+-- #minItems

496+

497+instance

498+ ( a ~ Maybe Integer, b ~ Maybe Integer

499+ ) => LabelOptic "minItems" A_Lens Header Header a b where

500+ labelOptic = #paramSchema % #minItems

501+ {-# INLINE labelOptic #-}

502+

503+instance

504+ ( a ~ Maybe Integer, b ~ Maybe Integer

505+ ) => LabelOptic "minItems" A_Lens Schema Schema a b where

506+ labelOptic = #paramSchema % #minItems

507+ {-# INLINE labelOptic #-}

508+

509+instance

510+ ( a ~ Maybe Integer, b ~ Maybe Integer

511+ ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where

512+ labelOptic = #paramSchema % #minItems

513+ {-# INLINE labelOptic #-}

514+

515+instance

516+ ( a ~ Maybe Integer, b ~ Maybe Integer

517+ ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

518+ labelOptic = #paramSchema % #minItems

519+ {-# INLINE labelOptic #-}

520+

521+-- #uniqueItems

522+

523+instance

524+ ( a ~ Maybe Bool, b ~ Maybe Bool

525+ ) => LabelOptic "uniqueItems" A_Lens Header Header a b where

526+ labelOptic = #paramSchema % #uniqueItems

527+ {-# INLINE labelOptic #-}

528+

529+instance

530+ ( a ~ Maybe Bool, b ~ Maybe Bool

531+ ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where

532+ labelOptic = #paramSchema % #uniqueItems

533+ {-# INLINE labelOptic #-}

534+

535+instance

536+ ( a ~ Maybe Bool, b ~ Maybe Bool

537+ ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where

538+ labelOptic = #paramSchema % #uniqueItems

539+ {-# INLINE labelOptic #-}

540+

541+instance

542+ ( a ~ Maybe Bool, b ~ Maybe Bool

543+ ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

544+ labelOptic = #paramSchema % #uniqueItems

545+ {-# INLINE labelOptic #-}

546+

547+-- #enum

548+

549+instance

550+ ( a ~ Maybe [Value], b ~ Maybe [Value]

551+ ) => LabelOptic "enum" A_Lens Header Header a b where

552+ labelOptic = #paramSchema % #enum

553+ {-# INLINE labelOptic #-}

554+

555+instance

556+ ( a ~ Maybe [Value], b ~ Maybe [Value]

557+ ) => LabelOptic "enum" A_Lens Schema Schema a b where

558+ labelOptic = #paramSchema % #enum

559+ {-# INLINE labelOptic #-}

560+

561+instance

562+ ( a ~ Maybe [Value], b ~ Maybe [Value]

563+ ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where

564+ labelOptic = #paramSchema % #enum

565+ {-# INLINE labelOptic #-}

566+

567+instance

568+ ( a ~ Maybe [Value], b ~ Maybe [Value]

569+ ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where

570+ labelOptic = #paramSchema % #enum

571+ {-# INLINE labelOptic #-}

572+

573+-- #multipleOf

574+

575+instance

576+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

577+ ) => LabelOptic "multipleOf" A_Lens Header Header a b where

578+ labelOptic = #paramSchema % #multipleOf

579+ {-# INLINE labelOptic #-}

580+

581+instance

582+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

583+ ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where

584+ labelOptic = #paramSchema % #multipleOf

585+ {-# INLINE labelOptic #-}

586+

587+instance

588+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

589+ ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where

590+ labelOptic = #paramSchema % #multipleOf

591+ {-# INLINE labelOptic #-}

592+

593+instance

594+ ( a ~ Maybe Scientific, b ~ Maybe Scientific

595+ ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where

596+ labelOptic = #paramSchema % #multipleOf

597+ {-# INLINE labelOptic #-}

src/Data/Swagger/Schema/Generator.hsnew file+114

@@ -0,0 +1,114 @@

1+{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE OverloadedLists #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

5+module Data.Swagger.Schema.Generator where

7+import Prelude ()

8+import Prelude.Compat

10+import Control.Lens.Operators

11+import Control.Monad (filterM)

12+import Data.Aeson

13+import Data.Aeson.Types

14+import qualified Data.HashMap.Strict.InsOrd as M

15+import Data.Maybe

16+import Data.Maybe

17+import Data.Proxy

18+import Data.Scientific

19+import qualified Data.Set as S

20+import Data.Swagger

21+import Data.Swagger.Declare

22+import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)

23+import qualified Data.Text as T

24+import qualified Data.Vector as V

25+import Test.QuickCheck (arbitrary)

26+import Test.QuickCheck.Gen

27+import Test.QuickCheck.Property

28+

29+-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30+-- and cannot be inferred.

31+schemaGen :: Definitions Schema -> Schema -> Gen Value

32+schemaGen _ schema

33+ | Just cases <- schema ^. paramSchema . enum_ = elements cases

34+schemaGen defns schema =

35+ case schema ^. type_ of

36+ Nothing ->

37+ case inferSchemaTypes schema of

38+ [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

39+ -- Gen is not MonadFail

40+ _ -> error "unable to infer schema type"

41+ Just SwaggerBoolean -> Bool <$> elements [True, False]

42+ Just SwaggerNull -> pure Null

43+ Just SwaggerNumber

44+ | Just min <- schema ^. minimum_

45+ , Just max <- schema ^. maximum_ ->

46+ Number . fromFloatDigits <$>

47+ choose (toRealFloat min, toRealFloat max :: Double)

48+ | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

49+ Just SwaggerInteger

50+ | Just min <- schema ^. minimum_

51+ , Just max <- schema ^. maximum_ ->

52+ Number . fromInteger <$>

53+ choose (truncate min, truncate max)

54+ | otherwise -> Number . fromInteger <$> arbitrary

55+ Just SwaggerArray

56+ | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

57+ | Just items <- schema ^. items ->

58+ case items of

59+ SwaggerItemsObject ref -> do

60+ size <- getSize

61+ let itemSchema = dereference defns ref

62+ minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems

63+ maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems

64+ arrayLength <- choose (minLength', max minLength' maxLength')

65+ generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema

66+ return . Array $ V.fromList generatedArray

67+ SwaggerItemsArray refs ->

68+ let itemGens = schemaGen defns . dereference defns <$> refs

69+ in fmap (Array . V.fromList) $ sequence itemGens

70+ Just SwaggerString -> do

71+ size <- getSize

72+ let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

73+ let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

74+ length <- choose (minLength', max minLength' maxLength')

75+ str <- vectorOf length arbitrary

76+ return . String $ T.pack str

77+ Just SwaggerObject -> do

78+ size <- getSize

79+ let props = dereference defns <$> schema ^. properties

80+ reqKeys = S.fromList $ schema ^. required

81+ allKeys = S.fromList . M.keys $ schema ^. properties

82+ optionalKeys = allKeys S.\\ reqKeys

83+ minProps' = fromMaybe (length reqKeys) $

84+ fromInteger <$> schema ^. minProperties

85+ maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties

86+ shuffledOptional <- shuffle $ S.toList optionalKeys

87+ numProps <- choose (minProps', max minProps' maxProps')

88+ let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional

89+ let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props

90+ let gens = schemaGen defns <$> presentProps

91+ additionalGens <- case schema ^. additionalProperties of

92+ Just (AdditionalPropertiesSchema addlSchema) -> do

93+ additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary

94+ return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

95+ _ -> return []

96+ x <- sequence $ gens <> additionalGens

97+ return . Object $ M.toHashMap x

98+ where

99+ dereference :: Definitions a -> Referenced a -> a

100+ dereference _ (Inline a) = a

101+ dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

102+

103+genValue :: (ToSchema a) => Proxy a -> Gen Value

104+genValue p =

105+ let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty

106+ in schemaGen defs schema

107+

108+validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property

109+validateFromJSON p = forAll (genValue p) $

110+ \val -> case parseEither parseJSON val of

111+ Right (_ :: a) -> succeeded

112+ Left err -> failed

113+ { reason = err

114+ }

src/Data/Swagger/Schema/Validation.hs+2

@@ -19,8 +19,10 @@ module Data.Swagger.Schema.Validation (

1919 ValidationError,

2020

2121 -- ** Using 'ToJSON' and 'ToSchema'

22+ validatePrettyToJSON,

2223 validateToJSON,

2324 validateToJSONWithPatternChecker,

25+ renderValidationErrors,

2426

2527 -- ** Using 'Value' and 'Schema'

2628 validateJSON,

stack-ghc-8.0.yamldeleted−5

@@ -1,5 +0,0 @@

1−resolver: nightly-2016-05-29

2−packages:

3−- '.'

4−extra-deps:

5− - aeson-0.11.2.1

stack-lts-2.yamldeleted−22

@@ -1,22 +0,0 @@

1−flags: {}

2−packages:

3−- '.'

4−extra-deps:

5−- aeson-0.11.2.1

6−- attoparsec-0.13.1.0

7−- base-compat-0.9.1

8−- fail-4.9.0.0

9−- generics-sop-0.2.1.0

10−- insert-ordered-containers-0.1.0.1

11−- primitive-0.6.1.0

12−- QuickCheck-2.8.2

13−- tagged-0.8.4

14−- unordered-containers-0.2.7.0

15−resolver: lts-2.22

16−flags:

17− aeson:

18− old-locale: true

19− QuickCheck:

20− base3: false

21− base4: true

22− base4point8: false

stack.yaml+6−2

@@ -1,5 +1,9 @@

1−resolver: lts-9.3

1+resolver: lts-14.3

22packages:

33- '.'

44extra-deps:

5−- aeson-1.2.2.0

5+- optics-core-0.2

6+- optics-th-0.2

7+- optics-extra-0.2

8+- indexed-profunctors-0.1

9+- insert-ordered-containers-0.2.3

swagger2.cabal+82−55

@@ -1,11 +1,15 @@

1+cabal-version: >=1.10

12name: swagger2

2−version: 2.2.1

3+version: 2.5

35synopsis: Swagger 2.0 data model

6+category: Web, Swagger

47description:

5− This library is inteded to be used for decoding and encoding Swagger 2.0 API

8+ This library is intended to be used for decoding and encoding Swagger 2.0 API

69 specifications as well as manipulating them.

710 .

811 The original Swagger 2.0 specification is available at http://swagger.io/specification/.

12+

913homepage: https://github.com/GetShopTV/swagger2

1014bug-reports: https://github.com/GetShopTV/swagger2/issues

1115license: BSD3

@@ -13,19 +17,22 @@ license-file: LICENSE

1317author: Nickolay Kudasov

1418maintainer: nickolay@getshoptv.com

16−category: Web, Swagger

1720build-type: Custom

1821extra-source-files:

1922 README.md

2023 , CHANGELOG.md

2124 , examples/*.hs

2225 , include/overlapping-compat.h

23−cabal-version: >=1.10

24−tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1

26+tested-with:

27+ GHC ==8.0.2

28+ || ==8.2.2

29+ || ==8.4.4

30+ || ==8.6.5

31+ || ==8.8.1

2532

2633custom-setup

2734 setup-depends:

28− base, Cabal, cabal-doctest >=1.0.2 && <1.1

35+ base, Cabal, cabal-doctest >=1.0.6 && <1.1

2936

3037library

3138 hs-source-dirs: src

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

3542 Data.Swagger.Declare

3643 Data.Swagger.Lens

3744 Data.Swagger.Operation

45+ Data.Swagger.Optics

3846 Data.Swagger.ParamSchema

3947 Data.Swagger.Schema

48+ Data.Swagger.Schema.Generator

4049 Data.Swagger.Schema.Validation

4150 Data.Swagger.SchemaOptions

4251

@@ -48,59 +57,79 @@ library

4857 Data.Swagger.Internal.Utils

4958 Data.Swagger.Internal.AesonUtils

5059 Data.Swagger.Internal.TypeShape

51− build-depends: base >=4.7 && <4.12

52− , base-compat >=0.9.1 && <0.10

53− , aeson >=1.0.0.0

54− , bytestring

55− , containers

56− , hashable

57− , generics-sop >=0.2 && <0.4

58− , http-media

59− , insert-ordered-containers >=0.1.0.0 && <0.3

60− , lens

61− , mtl

62− , network

63− , scientific

64− , text

65− , template-haskell

66− , time

67− , transformers

68− , transformers-compat >= 0.3

69− , unordered-containers

70− , vector

71− , uuid-types >=1.0.2 && <1.1

72− if !impl(ghc >= 7.10)

73− build-depends: nats >=1.1.1 && <1.2

74− if !impl(ghc >= 8.0)

75− build-depends: semigroups >= 0.18.3 && <0.19

60+

61+ -- GHC boot libraries

62+ build-depends:

63+ base >=4.9 && <4.14

64+ , aeson-pretty >=0.8.7 && <0.9

65+ , bytestring >=0.10.4.0 && <0.11

66+ , containers >=0.5.5.1 && <0.7

67+ , template-haskell >=2.9.0.0 && <2.16

68+ , time >=1.4.2 && <1.10

69+ , transformers >=0.3.0.0 && <0.6

70+

71+ build-depends:

72+ mtl >=2.1 && <2.3

73+ , text >=1.2.3.0 && <1.3

74+

75+ -- other dependencies

76+ build-depends:

77+ base-compat-batteries >=0.10.4 && <0.12

78+ , aeson >=1.4.2.0 && <1.5

79+ -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

80+ , cookie >=0.4.3 && <0.5

81+ , generics-sop >=0.3.2.0 && <0.6

82+ , hashable >=1.2.7.0 && <1.4

83+ , http-media >=0.7.1.2 && <0.9

84+ , insert-ordered-containers >=0.2.3 && <0.3

85+ , lens >=4.16.1 && <4.19

86+ , network >=2.6.3.5 && <3.2

87+ , optics-core >=0.2 && <0.3

88+ , optics-th >=0.2 && <0.3

89+ , scientific >=0.3.6.2 && <0.4

90+ , transformers-compat >=0.3 && <0.7

91+ , unordered-containers >=0.2.9.0 && <0.3

92+ , uuid-types >=1.0.3 && <1.1

93+ , vector >=0.12.0.1 && <0.13

94+ , QuickCheck >=2.10.1 && <2.14

95+

7696 default-language: Haskell2010

7797

7898test-suite spec

7999 type: exitcode-stdio-1.0

80100 hs-source-dirs: test

81101 main-is: Spec.hs

102+

103+ -- From library parat

82104 -- We need aeson's toEncoding for doctests too

83− build-depends: base

84− , base-compat

85− , aeson >=0.10.0.0

86− , aeson-qq

87− , bytestring

88− , containers

89− , hashable

90− , hspec

91− , insert-ordered-containers

92− , HUnit

93− , mtl

94− , QuickCheck >=2.8.2

95− , quickcheck-instances

96− , swagger2

97− , text

98− , time

99− , unordered-containers

100− , vector

101− , lens

102− if !impl(ghc >= 8.0)

103− build-depends: semigroups

105+ build-depends:

106+ base

107+ , swagger2

108+ , aeson

109+ , base-compat-batteries

110+ , bytestring

111+ , containers

112+ , hashable

113+ , insert-ordered-containers

114+ , lens

115+ , mtl

116+ , template-haskell

117+ , text

118+ , time

119+ , unordered-containers

120+ , vector

121+ , QuickCheck

122+

123+ -- test-suite only dependencies

124+ build-depends:

125+ hspec >=2.5.5 && <2.8

126+ , HUnit >=1.6.0.0 && <1.7

127+ , quickcheck-instances >=0.3.19 && <0.14

128+ , utf8-string >=1.0.1.1 && <1.1

129+

130+ -- https://github.com/haskell/cabal/issues/3708

131+ build-tool-depends:

132+ hspec-discover:hspec-discover >=2.5.5 && <2.8

104133

105134 other-modules:

106135 SpecCommon

@@ -109,10 +138,8 @@ test-suite spec

109138 Data.Swagger.ParamSchemaSpec

110139 Data.Swagger.SchemaSpec

111140 Data.Swagger.Schema.ValidationSpec

141+ Data.Swagger.Schema.GeneratorSpec

112142 default-language: Haskell2010

113− -- https://github.com/haskell/cabal/issues/3708

114− build-tool-depends:

115− hspec-discover:hspec-discover

116143

117144test-suite doctests

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

test/Data/Swagger/CommonTestTypes.hs+45−18

@@ -1,25 +1,23 @@

1−{-# LANGUAGE DeriveGeneric #-}

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE QuasiQuotes #-}

23{-# LANGUAGE ScopedTypeVariables #-}

3−{-# LANGUAGE QuasiQuotes #-}

55module Data.Swagger.CommonTestTypes where

7−import Prelude ()

8−import Prelude.Compat

7+import Prelude ()

8+import Prelude.Compat

10−import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))

11−import Data.Aeson.Types (toJSONKeyText)

12−import Data.Aeson.QQ

13−import Data.Char

14−import Data.Proxy

15−import Data.Set (Set)

16−import Data.Map (Map)

17−import qualified Data.Text as Text

18−import GHC.Generics

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

1919

20−import Data.Swagger

21−import Data.Swagger.Declare

22−import Data.Swagger.Internal (SwaggerKind(..))

20+import Data.Swagger

2321

2422-- ========================================================================

2523-- Unit type

@@ -552,7 +550,7 @@ lightSchemaJSON = [aesonQQ|

552550 "type": "object",

553551 "properties":

554552 {

555− "NoLight": { "type": "array", "items": [] },

553+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

556554 "LightFreq": { "type": "number", "format": "double" },

557555 "LightColor": { "$ref": "#/definitions/Color" },

558556 "LightWaveLength": { "type": "number", "format": "double" }

@@ -568,7 +566,7 @@ lightInlinedSchemaJSON = [aesonQQ|

568566 "type": "object",

569567 "properties":

570568 {

571− "NoLight": { "type": "array", "items": [] },

569+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

572570 "LightFreq": { "type": "number", "format": "double" },

573571 "LightColor":

574572 {

@@ -650,3 +648,32 @@ singleMaybeFieldSchemaJSON = [aesonQQ|

650648 }

651649}

652650|]

651+

652+

653+-- ========================================================================

654+-- TimeOfDay

655+-- ========================================================================

656+data TimeOfDay

657+ = Int

658+ | Pico

659+ deriving (Generic)

660+instance ToSchema TimeOfDay

661+instance ToParamSchema TimeOfDay

662+

663+

664+timeOfDaySchemaJSON :: Value

665+timeOfDaySchemaJSON = [aesonQQ|

666+{

667+ "example": "12:33:15",

668+ "type": "string",

669+ "format": "hh:MM:ss"

670+}

671+|]

672+

673+timeOfDayParamSchemaJSON :: Value

674+timeOfDayParamSchemaJSON = [aesonQQ|

675+{

676+ "type": "string",

677+ "format": "hh:MM:ss"

678+}

679+|]

test/Data/Swagger/ParamSchemaSpec.hs+7−2

@@ -3,10 +3,11 @@

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE TemplateHaskell #-}

55{-# LANGUAGE QuasiQuotes #-}

6+{-# LANGUAGE OverloadedStrings #-}

67module Data.Swagger.ParamSchemaSpec where

8−import Data.Aeson (Value)

9−import Data.Aeson.QQ

9+import Data.Aeson

10+import Data.Aeson.QQ.Simple

1011import Data.Char

1112import Data.Proxy

1213import GHC.Generics

@@ -17,6 +18,9 @@ import Data.Swagger.Internal (SwaggerKind(..))

1718import Data.Swagger.CommonTestTypes

1819import SpecCommon

1920import Test.Hspec

21+import Data.Time.LocalTime

22+

23+import qualified Data.HashMap.Strict as HM

2024

2125checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

2226checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

@@ -30,6 +34,7 @@ spec = do

3034 context "Unary records" $ do

3135 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

3236 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

3338

3439main :: IO ()

3540main = hspec spec

test/Data/Swagger/Schema/GeneratorSpec.hsnew file+168

@@ -0,0 +1,168 @@

1+{-# LANGUAGE OverloadedLists #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE PackageImports #-}

4+module Data.Swagger.Schema.GeneratorSpec where

6+import Prelude ()

7+import Prelude.Compat

9+import Data.Swagger

10+import Data.Swagger.Schema.Generator

11+

12+import Control.Lens.Operators

13+import Data.Aeson

14+import Data.Hashable (Hashable)

15+import Data.HashMap.Strict (HashMap)

16+import qualified Data.HashMap.Strict as HashMap

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

18+import qualified "unordered-containers" Data.HashSet as HashSet

19+import Data.Int

20+import Data.IntMap (IntMap)

21+import Data.List.NonEmpty.Compat (NonEmpty (..), nonEmpty)

22+import Data.Map (Map, fromList)

23+import Data.Monoid (mempty)

24+import Data.Proxy

25+import Data.Proxy

26+import Data.Set (Set)

27+import qualified Data.Text as T

28+import qualified Data.Text.Lazy as TL

29+import Data.Time

30+import Data.Version (Version)

31+import Data.Word

32+import GHC.Generics

33+

34+import Test.Hspec

35+import Test.Hspec.QuickCheck

36+import Test.QuickCheck

37+

38+shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

39+shouldValidate = validateFromJSON

40+

41+

42+shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

43+shouldNotValidate = expectFailure . shouldValidate

44+

45+

46+spec :: Spec

47+spec = do

48+ describe "FromJSON validation" $ do

49+ prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)

50+ prop "Char" $ shouldValidate (Proxy :: Proxy Char)

51+ prop "Double" $ shouldValidate (Proxy :: Proxy Double)

52+ prop "Float" $ shouldValidate (Proxy :: Proxy Float)

53+ prop "Int" $ shouldValidate (Proxy :: Proxy Int)

54+ prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)

55+ prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)

56+ prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)

57+ prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)

58+ prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)

59+ prop "Word" $ shouldValidate (Proxy :: Proxy Word)

60+ prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)

61+ prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)

62+ prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)

63+ prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)

64+ prop "String" $ shouldValidate (Proxy :: Proxy String)

65+ prop "()" $ shouldValidate (Proxy :: Proxy ())

66+-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)

67+-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)

68+ prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)

69+ prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)

70+ prop "[String]" $ shouldValidate (Proxy :: Proxy [String])

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

72+ prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

73+ prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

74+ prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))

75+ prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

76+ prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

77+ prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

78+ prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))

79+ prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))

80+ prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))

81+ prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

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

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

84+ prop "Object" $ shouldValidate (Proxy :: Proxy Object)

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

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

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

88+ describe "Invalid FromJSON validation" $ do

89+ prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)

90+ prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)

91+ prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)

92+ prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)

93+

94+-- =============================

95+-- Data types and bunk instances

96+-- =============================

97+

98+data WrongType = WrongType Bool

99+

100+instance FromJSON WrongType where

101+ parseJSON = withBool "WrongType" $ return . WrongType

102+

103+instance ToSchema WrongType where

104+ declareNamedSchema _ = return . NamedSchema (Just "WrongType") $

105+ mempty

106+ & type_ ?~ SwaggerObject

107+

108+

109+data MissingRequired = MissingRequired

110+ { propA :: String

111+ , propB :: Bool

112+ }

113+

114+instance FromJSON MissingRequired where

115+ parseJSON = withObject "MissingRequired" $ \o ->

116+ MissingRequired

117+ <$> o .: "propA"

118+ <*> o .: "propB"

119+

120+instance ToSchema MissingRequired where

121+ declareNamedSchema _ = do

122+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)

123+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

124+ return . NamedSchema (Just "MissingRequired") $

125+ mempty

126+ & type_ ?~ SwaggerObject

127+ & properties .~ [("propA", stringSchema)

128+ ,("propB", boolSchema)

129+ ]

130+ & required .~ ["propA"]

131+

132+data MissingProperty = MissingProperty

133+ { propC :: String

134+ , propD :: Bool

135+ }

136+

137+instance FromJSON MissingProperty where

138+ parseJSON = withObject "MissingProperty" $ \o ->

139+ MissingProperty

140+ <$> o .: "propC"

141+ <*> o .: "propD"

142+

143+instance ToSchema MissingProperty where

144+ declareNamedSchema _ = do

145+ stringSchema <- declareSchemaRef (Proxy :: Proxy String)

146+ return . NamedSchema (Just "MissingProperty") $

147+ mempty

148+ & type_ ?~ SwaggerObject

149+ & properties .~ [("propC", stringSchema)]

150+ & required .~ ["propC"]

151+

152+data WrongPropType = WrongPropType

153+ { propE :: String

154+ }

155+

156+instance FromJSON WrongPropType where

157+ parseJSON = withObject "WrongPropType" $ \o ->

158+ WrongPropType

159+ <$> o .: "propE"

160+

161+instance ToSchema WrongPropType where

162+ declareNamedSchema _ = do

163+ boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

164+ return . NamedSchema (Just "WrongPropType") $

165+ mempty

166+ & type_ ?~ SwaggerObject

167+ & properties .~ [("propE", boolSchema)]

168+ & required .~ ["propE"]

test/Data/Swagger/Schema/ValidationSpec.hs+76−35

@@ -1,40 +1,41 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE PackageImports #-}

4−{-# LANGUAGE RecordWildCards #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE PackageImports #-}

4+{-# LANGUAGE RecordWildCards #-}

55{-# LANGUAGE ScopedTypeVariables #-}

66{-# OPTIONS_GHC -fno-warn-orphans #-}

77module Data.Swagger.Schema.ValidationSpec where

9−import Control.Applicative

10−import Data.Aeson

11−import Data.Aeson.Types

12−import Data.Int

13−import Data.IntMap (IntMap)

14−import Data.Hashable (Hashable)

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

9+import Control.Applicative

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

11+import Data.Aeson

12+import Data.Aeson.Types

13+import Data.Hashable (Hashable)

14+import Data.HashMap.Strict (HashMap)

15+import qualified Data.HashMap.Strict as HashMap

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

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

17−import Data.HashMap.Strict (HashMap)

18−import qualified Data.HashMap.Strict as HashMap

19−import Data.List.NonEmpty (NonEmpty(..), nonEmpty)

20−import Data.Map (Map)

21−import Data.Monoid (mempty)

22−import Data.Proxy

23−import Data.Time

24−import qualified Data.Text as T

25−import qualified Data.Text.Lazy as TL

26−import Data.Version (Version)

27−import Data.Set (Set)

28−import Data.Word

29−import GHC.Generics

30−

31−import Data.Swagger

32−import Data.Swagger.Declare

33−

34−import Test.Hspec

35−import Test.Hspec.QuickCheck

36−import Test.QuickCheck

37−import Test.QuickCheck.Instances ()

18+import Data.Int

19+import Data.IntMap (IntMap)

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

21+import Data.Map (Map, fromList)

22+import Data.Monoid (mempty)

23+import Data.Proxy

24+import Data.Set (Set)

25+import qualified Data.Text as T

26+import qualified Data.Text.Lazy as TL

27+import Data.Time

28+import Data.Version (Version)

29+import Data.Word

30+import GHC.Generics

31+

32+import Data.Swagger

33+import Data.Swagger.Declare

34+

35+import Test.Hspec

36+import Test.Hspec.QuickCheck

37+import Test.QuickCheck

38+import Test.QuickCheck.Instances ()

3839

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

4041shouldValidate _ x = validateToJSON x == []

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

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

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

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

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

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

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

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

@@ -92,6 +94,7 @@ spec = do

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

9395 prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)

9496 prop "Version" $ shouldValidate (Proxy :: Proxy Version)

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

9598

9699 describe "invalid cases" $ do

97100 prop "invalidPersonToJSON" $ shouldNotValidate invalidPersonToJSON

@@ -137,9 +140,9 @@ instance Arbitrary Color where

137140 arbitrary = arbitraryBoundedEnum

138141

139142invalidColorToJSON :: Color -> Value

140−invalidColorToJSON Red = toJSON "red"

141−invalidColorToJSON Green = toJSON "green"

142−invalidColorToJSON Blue = toJSON "blue"

143+invalidColorToJSON Red = toJSON "red"

144+invalidColorToJSON Green = toJSON "green"

145+invalidColorToJSON Blue = toJSON "blue"

143146

144147-- ========================================================================

145148-- Paint (record with bounded enum property)

@@ -233,5 +236,43 @@ invalidButtonImagesToJSON = genericToJSON defaultOptions

233236instance Arbitrary ButtonImages where

234237 arbitrary = ButtonImages <$> arbitrary

235238

239+-- ========================================================================

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

241+-- ========================================================================

242+

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

244+ deriving (Show, Generic)

245+

246+instance ToJSON FreeForm where

247+ toJSON = toJSON . jsonContent

248+

249+instance ToSchema FreeForm where

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

251+ & type_ ?~ SwaggerObject

252+ & additionalProperties ?~ AdditionalPropertiesAllowed True

253+

254+instance Arbitrary FreeForm where

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

256+ where

257+ genObj = listOf $ do

258+ k <- arbitrary

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

260+ pure (k, v)

261+

236262instance Eq ZonedTime where

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

264+

265+-- ========================================================================

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

267+-- ========================================================================

268+

269+instance Arbitrary Value where

270+ -- Weights are almost random

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

272+ arbitrary = resize 4 $ frequency

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

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

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

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

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

278+ , (1, return Null) ]

test/Data/Swagger/SchemaSpec.hs+5−6

@@ -8,16 +8,11 @@ import Prelude ()

88import Prelude.Compat

1010import Control.Lens ((^.))

11−import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))

12−import Data.Aeson.Types (toJSONKeyText)

13−import Data.Aeson.QQ

14−import Data.Char

11+import Data.Aeson (Value)

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

1613import Data.Proxy

1714import Data.Set (Set)

18−import Data.Map (Map)

1915import qualified Data.Text as Text

20−import GHC.Generics

2116

2217import Data.Swagger

2318import Data.Swagger.Declare

@@ -26,6 +21,9 @@ import Data.Swagger.CommonTestTypes

2621import SpecCommon

2722import Test.Hspec

2823

24+import qualified Data.HashMap.Strict as HM

25+import Data.Time.LocalTime

26+

2927checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

3028checkToSchema proxy js = toSchema proxy <=> js

3129

@@ -110,6 +108,7 @@ spec = do

110108 context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

111109 describe "Bounded Enum key mapping" $ do

112110 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

111+ context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON

113112

114113main :: IO ()

115114main = hspec spec

test/Data/SwaggerSpec.hs+86−31

@@ -10,9 +10,9 @@ import Prelude.Compat

1010import Control.Lens

1111

1212import Data.Aeson

13−import Data.Aeson.QQ

13+import Data.Aeson.QQ.Simple

1414import Data.HashMap.Strict (HashMap)

15−import qualified Data.Set as Set

15+import qualified Data.HashSet.InsOrd as InsOrdHS

1616import Data.Text (Text)

1717

1818import Data.Swagger

@@ -37,11 +37,13 @@ spec = do

3737 context "Primitive Sample" $ schemaPrimitiveExample <=> schemaPrimitiveExampleJSON

3838 context "Simple Model" $ schemaSimpleModelExample <=> schemaSimpleModelExampleJSON

3939 context "Model with Map/Dictionary Properties" $ schemaModelDictExample <=> schemaModelDictExampleJSON

40+ context "Model with Arbitrary Properties" $ schemaAdditionalExample <=> schemaAdditionalExampleJSON

4041 context "Model with Example" $ schemaWithExampleExample <=> schemaWithExampleExampleJSON

4142 describe "Definitions Object" $ definitionsExample <=> definitionsExampleJSON

4243 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

4344 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

4445 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

4547 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

4648 describe "Swagger Object" $ do

4749 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

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

126128

127129operationExample :: Operation

128130operationExample = mempty

129− & tags .~ Set.fromList ["pet"]

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

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

131133 & description ?~ ""

132134 & operationId ?~ "updatePetWithForm"

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

157159 stringSchema :: ParamLocation -> ParamOtherSchema

158160 stringSchema loc = mempty

159161 & in_ .~ loc

160− & type_ .~ SwaggerString

162+ & type_ ?~ SwaggerString

161163

162164operationExampleJSON :: Value

163165operationExampleJSON = [aesonQQ|

@@ -223,7 +225,7 @@ operationExampleJSON = [aesonQQ|

223225

224226schemaPrimitiveExample :: Schema

225227schemaPrimitiveExample = mempty

226− & type_ .~ SwaggerString

228+ & type_ ?~ SwaggerString

227229 & format ?~ "email"

228230

229231schemaPrimitiveExampleJSON :: Value

@@ -236,14 +238,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

236238

237239schemaSimpleModelExample :: Schema

238240schemaSimpleModelExample = mempty

239− & type_ .~ SwaggerObject

241+ & type_ ?~ SwaggerObject

240242 & required .~ [ "name" ]

241243 & properties .~

242− [ ("name", Inline (mempty & type_ .~ SwaggerString))

244+ [ ("name", Inline (mempty & type_ ?~ SwaggerString))

243245 , ("address", Ref (Reference "Address"))

244246 , ("age", Inline $ mempty

245247 & minimum_ ?~ 0

246− & type_ .~ SwaggerInteger

248+ & type_ ?~ SwaggerInteger

247249 & format ?~ "int32" ) ]

248250

249251schemaSimpleModelExampleJSON :: Value

@@ -271,8 +273,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

271273

272274schemaModelDictExample :: Schema

273275schemaModelDictExample = mempty

274− & type_ .~ SwaggerObject

275− & additionalProperties ?~ Inline (mempty & type_ .~ SwaggerString)

276+ & type_ ?~ SwaggerObject

277+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

276278

277279schemaModelDictExampleJSON :: Value

278280schemaModelDictExampleJSON = [aesonQQ|

@@ -284,15 +286,28 @@ schemaModelDictExampleJSON = [aesonQQ|

284286}

285287|]

286288

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+

287302schemaWithExampleExample :: Schema

288303schemaWithExampleExample = mempty

289− & type_ .~ SwaggerObject

304+ & type_ ?~ SwaggerObject

290305 & properties .~

291306 [ ("id", Inline $ mempty

292− & type_ .~ SwaggerInteger

307+ & type_ ?~ SwaggerInteger

293308 & format ?~ "int64" )

294309 , ("name", Inline $ mempty

295− & type_ .~ SwaggerString) ]

310+ & type_ ?~ SwaggerString) ]

296311 & required .~ [ "name" ]

297312 & example ?~ [aesonQQ|

298313 {

@@ -331,19 +346,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

331346definitionsExample :: HashMap Text Schema

332347definitionsExample =

333348 [ ("Category", mempty

334− & type_ .~ SwaggerObject

349+ & type_ ?~ SwaggerObject

335350 & properties .~

336351 [ ("id", Inline $ mempty

337− & type_ .~ SwaggerInteger

352+ & type_ ?~ SwaggerInteger

338353 & format ?~ "int64")

339− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

354+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

340355 , ("Tag", mempty

341− & type_ .~ SwaggerObject

356+ & type_ ?~ SwaggerObject

342357 & properties .~

343358 [ ("id", Inline $ mempty

344− & type_ .~ SwaggerInteger

359+ & type_ ?~ SwaggerInteger

345360 & format ?~ "int64")

346− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

361+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

347362

348363definitionsExampleJSON :: Value

349364definitionsExampleJSON = [aesonQQ|

@@ -387,7 +402,7 @@ paramsDefinitionExample =

387402 & required ?~ True

388403 & schema .~ ParamOther (mempty

389404 & in_ .~ ParamQuery

390− & type_ .~ SwaggerInteger

405+ & type_ ?~ SwaggerInteger

391406 & format ?~ "int32" ))

392407 , ("limitParam", mempty

393408 & name .~ "limit"

@@ -395,7 +410,7 @@ paramsDefinitionExample =

395410 & required ?~ True

396411 & schema .~ ParamOther (mempty

397412 & in_ .~ ParamQuery

398− & type_ .~ SwaggerInteger

413+ & type_ ?~ SwaggerInteger

399414 & format ?~ "int32" )) ]

400415

401416paramsDefinitionExampleJSON :: Value

@@ -445,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

445460-- Responses Definition object

446461-- =======================================================================

447462

448−securityDefinitionsExample :: HashMap Text SecurityScheme

449−securityDefinitionsExample =

463+securityDefinitionsExample :: SecurityDefinitions

464+securityDefinitionsExample = SecurityDefinitions

450465 [ ("api_key", SecurityScheme

451466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

452467 , _securitySchemeDescription = Nothing })

@@ -478,6 +493,46 @@ securityDefinitionsExampleJSON = [aesonQQ|

478493}

479494|]

480495

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+

481536-- =======================================================================

482537-- Swagger object

483538-- =======================================================================

@@ -496,7 +551,7 @@ swaggerExample = mempty

496551 & at 200 ?~ Inline (mempty

497552 & description .~ "OK"

498553 & schema ?~ Inline (mempty

499− & type_ .~ SwaggerObject

554+ & type_ ?~ SwaggerObject

500555 & example ?~ [aesonQQ|

501556 {

502557 "created": 100,

@@ -505,9 +560,9 @@ swaggerExample = mempty

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

506561 & properties .~

507562 [ ("created", Inline $ mempty

508− & type_ .~ SwaggerInteger

563+ & type_ ?~ SwaggerInteger

509564 & format ?~ "int32")

510− , ("description", Inline (mempty & type_ .~ SwaggerString))]))

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

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

512567 & parameters .~

513568 [ Inline $ mempty

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

516571 & description ?~ "TodoId param"

517572 & schema .~ ParamOther (mempty

518573 & in_ .~ ParamPath

519− & type_ .~ SwaggerString ) ]

520− & tags .~ Set.fromList [ "todo" ] ))

574+ & type_ ?~ SwaggerString ) ]

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

521576

522577swaggerExampleJSON :: Value

523578swaggerExampleJSON = [aesonQQ|

@@ -1618,14 +1673,14 @@ petstoreExampleJSON = [aesonQQ|

16181673

16191674compositionSchemaExample :: Schema

16201675compositionSchemaExample = mempty

1621− & type_ .~ SwaggerObject

1676+ & type_ ?~ SwaggerObject

16221677 & Data.Swagger.allOf ?~ [

16231678 Ref (Reference "Other")

16241679 , Inline (mempty

1625− & type_ .~ SwaggerObject

1680+ & type_ ?~ SwaggerObject

16261681 & properties .~

16271682 [ ("greet", Inline $ mempty

1628− & type_ .~ SwaggerString) ])

1683+ & type_ ?~ SwaggerString) ])

16291684 ]

16301685

16311686compositionSchemaExampleJSON :: Value