f37ffaf...master · typeable/swagger2

git.iko.soy/typeable/swagger2

.ghci+1

since splitsnapshots

@@ -1 +1,2 @@

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

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

.travis.yml+128−87

@@ -1,121 +1,162 @@

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

3−# runghc make_travis_yml_2.hs '--branch' 'master' '--output' '.travis.yml' 'swagger2.cabal' '--env=8.2.2:HADDOCK=false' '--env=8.0.2:HADDOCK=false' '--env=7.10.3:HADDOCK=false' '--env=7.8.4:HADDOCK=false'

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

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

7+# version: 0.5.20191020

8+#

7language: c

9language: c

8−sudo: false

10+dist: xenial

9−

10git:

11git:

11− submodules: false # whether to recursively clone submodules

12+ # whether to recursively clone submodules

12−

13+ submodules: false

13branches:

14branches:

14 only:

15 only:

15 - master

16 - master

16−

17cache:

18 directories:

19 - $HOME/.cabal/packages

20 - $HOME/.cabal/store

21−

22before_cache:

21before_cache:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

30−

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

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

32−

33matrix:

30matrix:

34 include:

31 include:

35− - compiler: "ghc-8.6.1"

32+ - compiler: ghc-8.8.1

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

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

37− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}}

38− - compiler: "ghc-8.4.4"

34+ - compiler: ghc-8.6.5

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

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

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

41− - compiler: "ghc-8.2.2"

36+ - compiler: ghc-8.4.4

42− env: HADDOCK=false

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

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

44− - compiler: "ghc-8.0.2"

38+ - compiler: ghc-8.2.2

45− env: HADDOCK=false

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

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

47− - compiler: "ghc-7.10.3"

40+ - compiler: ghc-8.0.2

48− env: HADDOCK=false

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

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

50− - compiler: "ghc-7.8.4"

51− env: HADDOCK=false

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

53−

54before_install:

42before_install:

55− - HC=${CC}

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

44+ - WITHCOMPILER="-w $HC"

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

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

46+ - HCPKG="$HC-pkg"

57 - unset CC

47 - unset CC

58− - ROOTDIR=$(pwd)

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

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

49+ - CABALHOME=$HOME/.cabal

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

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

51+ - TOP=$(pwd)

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

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

62 - echo $HCNUMVER

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

64install:

74install:

65− - cabal --version

75+ - ${CABAL} --version

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

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

77+ - TEST=--enable-tests

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

78+ - BENCH=--enable-benchmarks

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

79+ - HEADHACKAGE=false

69− - HADDOCK=${HADDOCK-true}

80+ - rm -f $CABALHOME/config

70− - UNCONSTRAINED=${UNCONSTRAINED-true}

81+ - |

71− - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}

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

72− - GHCHEAD=${GHCHEAD-false}

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

73− - travis_retry cabal update -v

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

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

111+ # Generate cabal.project

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

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

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

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

78− - touch cabal.project.local

113+ - touch cabal.project

114+ - |

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

116+ - |

79− - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- swagger2 | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

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"

80 - cat cabal.project || true

118 - cat cabal.project || true

81 - cat cabal.project.local || true

119 - cat cabal.project.local || true

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

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

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

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

84− fi

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

85− - rm -f cabal.project.freeze

123+ - rm cabal.project.freeze

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

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

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

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

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

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

90−

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

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

93script:

126script:

94− # test that source-distributions can be generated

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

95− - cabal new-sdist all

128+ # Packaging...

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

130+ # Unpacking...

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

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

97 - cd ${DISTDIR} || false

132 - cd ${DISTDIR} || false

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

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.]*')"

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

136+ # Generate cabal.project

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

100− - touch cabal.project.local

138+ - touch cabal.project

139+ - |

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

141+ - |

101− - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- swagger2 | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"

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"

102 - cat cabal.project || true

143 - cat cabal.project || true

103 - cat cabal.project.local || true

144 - cat cabal.project.local || true

145+ # Building...

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

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

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

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

106−

148+ # Building with tests and benchmarks...

107 # build & run tests, build benchmarks

149 # build & run tests, build benchmarks

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

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

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

151+ # Testing...

110−

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

111− # cabal check

153+ # cabal check...

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

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

113−

114− # haddock

155+ # haddock...

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

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

116−

117− # Build without installed constraints for packages in global-db

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

118− - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi

158+ - rm -f cabal.project.local

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

119

160

120−# REGENDATA ["--branch","master","--output",".travis.yml","swagger2.cabal","--env=8.2.2:HADDOCK=false","--env=8.0.2:HADDOCK=false","--env=7.10.3:HADDOCK=false","--env=7.8.4:HADDOCK=false"]

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

121# EOF

162# EOF

CHANGELOG.md+40

@@ -1,3 +1,43 @@

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+

12.3.0.1

412.3.0.1

2-------

42-------

aeson-0.11.cabal.configdeleted−1

@@ -1 +0,0 @@

1−constraints: aeson ==0.11.*

cabal.projectnew file+2

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

1+packages: .

2+tests: true

examples/hackage.hs+1−1

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

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

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

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

30− & type_ .~ SwaggerObject

30+ & type_ ?~ SwaggerObject

31 & properties .~

32 [ ("summaryUsername", usernameSchema )

33 , ("summaryUserid" , useridSchema )

src/Data/Swagger.hs+9−4

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

32 -- * Re-exports

33 module Data.Swagger.Lens,

34+ module Data.Swagger.Optics,

34 module Data.Swagger.Operation,

35 module Data.Swagger.Operation,

35 module Data.Swagger.ParamSchema,

36 module Data.Swagger.ParamSchema,

36 module Data.Swagger.Schema,

37 module Data.Swagger.Schema,

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

88 SecurityScheme(..),

89 SecurityScheme(..),

89 SecuritySchemeType(..),

90 SecuritySchemeType(..),

90 SecurityRequirement(..),

91 SecurityRequirement(..),

92+ SecurityDefinitions(..),

92 -- *** API key

94 -- *** API key

93 ApiKeyParams(..),

95 ApiKeyParams(..),

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

112) where

114) where

113

115

114import Data.Swagger.Lens

116import Data.Swagger.Lens

117+import Data.Swagger.Optics ()

115import Data.Swagger.Operation

118import Data.Swagger.Operation

116import Data.Swagger.ParamSchema

119import Data.Swagger.ParamSchema

117import Data.Swagger.Schema

120import Data.Swagger.Schema

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

175

178

176-- $lens

179-- $lens

177--

180--

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

182+--

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

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

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

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

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

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

181--

186--

182-- >>> :{

187-- >>> :{

183-- encode $ (mempty :: Swagger)

188-- encode $ (mempty :: Swagger)

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

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

185-- & paths .~

190-- & paths .~

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

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

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

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

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

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

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

205-- >>> :{

210-- >>> :{

206-- encode $ (mempty :: Schema)

211-- encode $ (mempty :: Schema)

207−-- & type_ .~ SwaggerBoolean

212+-- & type_ ?~ SwaggerBoolean

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

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

209-- :}

214-- :}

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

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

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

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

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

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

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

215--

220--

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

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

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

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

218--

223--

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

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

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

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

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

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

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

277--

282--

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

279-- schema for basic enums like

284-- schema for basic enums like

280--

285--

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

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

src/Data/Swagger/Internal.hs+85−10

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

29import Data.Aeson

30import qualified Data.Aeson.Types as JSON

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

32+import Data.Hashable (Hashable)

32import qualified Data.HashMap.Strict as HashMap

33import qualified Data.HashMap.Strict as HashMap

34+import Data.HashSet.InsOrd (InsOrdHashSet)

33import Data.Map (Map)

35import Data.Map (Map)

34import qualified Data.Map as Map

36import qualified Data.Map as Map

35import Data.Monoid (Monoid (..))

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

36import Data.Semigroup.Compat (Semigroup (..))

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

37import Data.Scientific (Scientific)

39import Data.Scientific (Scientific)

38−import Data.Set (Set)

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

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

40import Data.Text (Text)

41import Data.Text (Text)

41import qualified Data.Text as Text

42import qualified Data.Text as Text

42import GHC.Generics (Generic)

43import GHC.Generics (Generic)

43−import Network (HostName, PortNumber)

44+import Network.Socket (HostName, PortNumber)

44import Network.HTTP.Media (MediaType)

45import Network.HTTP.Media (MediaType)

45import Text.Read (readMaybe)

46import Text.Read (readMaybe)

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

65#define DEFINE_TOENCODING

66#define DEFINE_TOENCODING

66#endif

67#endif

69+-- $setup

70+-- >>> :seti -XDataKinds

71+-- >>> import Data.Aeson

72+

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

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

69type Definitions = InsOrdHashMap Text

74type Definitions = InsOrdHashMap Text

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

112 , _swaggerResponses :: Definitions Response

117 , _swaggerResponses :: Definitions Response

113

118

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

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

115− , _swaggerSecurityDefinitions :: Definitions SecurityScheme

120+ , _swaggerSecurityDefinitions :: SecurityDefinitions

116

121

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

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

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

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

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

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

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

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

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

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

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

128− , _swaggerTags :: Set Tag

133+ , _swaggerTags :: InsOrdHashSet Tag

129

134

130 -- | Additional external documentation.

135 -- | Additional external documentation.

131 , _swaggerExternalDocs :: Maybe ExternalDocs

136 , _swaggerExternalDocs :: Maybe ExternalDocs

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

247data Operation = Operation

252data Operation = Operation

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

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

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

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

250− _operationTags :: Set TagName

255+ _operationTags :: InsOrdHashSet TagName

251

256

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

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

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

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

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

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

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

590 _paramSchemaDefault :: Maybe Value

595 _paramSchemaDefault :: Maybe Value

591

596

592− , _paramSchemaType :: SwaggerType t

597+ , _paramSchemaType :: Maybe (SwaggerType t)

593 , _paramSchemaFormat :: Maybe Format

598 , _paramSchemaFormat :: Maybe Format

594 , _paramSchemaItems :: Maybe (SwaggerItems t)

599 , _paramSchemaItems :: Maybe (SwaggerItems t)

595 , _paramSchemaMaximum :: Maybe Scientific

600 , _paramSchemaMaximum :: Maybe Scientific

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

606 , _paramSchemaMultipleOf :: Maybe Scientific

611 , _paramSchemaMultipleOf :: Maybe Scientific

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

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

608

613

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)

610

615

611data Xml = Xml

616data Xml = Xml

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

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

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

750 , _securitySchemeDescription :: Maybe Text

755 , _securitySchemeDescription :: Maybe Text

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

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

752

757

758+

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

760+-- In other case returns first security scheme

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

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

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

764+ = if flow1 == flow2 then

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

766+ else

767+ s1

768+mergeSecurityScheme s1 _ = s1

769+

770+newtype SecurityDefinitions

771+ = SecurityDefinitions (Definitions SecurityScheme)

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

773+

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

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

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

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

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

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

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

774 , _tagExternalDocs :: Maybe ExternalDocs

795 , _tagExternalDocs :: Maybe ExternalDocs

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

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

776

797

798+instance Hashable Tag

799+

777instance IsString Tag where

800instance IsString Tag where

778 fromString s = Tag (fromString s) Nothing Nothing

801 fromString s = Tag (fromString s) Nothing Nothing

779

802

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

787 , _externalDocsUrl :: URL

810 , _externalDocsUrl :: URL

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

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

789

812

813+instance Hashable ExternalDocs

814+

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

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

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

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

792newtype Reference = Reference { getReference :: Text }

817newtype Reference = Reference { getReference :: Text }

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

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

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

801 fromString = Inline . fromString

826 fromString = Inline . fromString

802

827

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)

804

829

805data AdditionalProperties

830data AdditionalProperties

806 = AdditionalPropertiesAllowed Bool

831 = AdditionalPropertiesAllowed Bool

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

895 mempty = genericMempty

920 mempty = genericMempty

896 mappend = (<>)

921 mappend = (<>)

897

922

923+instance Semigroup SecurityScheme where

924+ (<>) = mergeSecurityScheme

925+

926+instance Semigroup SecurityDefinitions where

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

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

929+

930+instance Monoid SecurityDefinitions where

931+ mempty = SecurityDefinitions $ InsOrdHashMap.empty

932+ mappend = (<>)

933+

898-- =======================================================================

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

899-- SwaggerMonoid helper instances

935-- SwaggerMonoid helper instances

900-- =======================================================================

936-- =======================================================================

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

909instance SwaggerMonoid Response

945instance SwaggerMonoid Response

910instance SwaggerMonoid ExternalDocs

946instance SwaggerMonoid ExternalDocs

911instance SwaggerMonoid Operation

947instance SwaggerMonoid Operation

948+instance SwaggerMonoid SecurityDefinitions

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

912

950

913instance SwaggerMonoid MimeList

951instance SwaggerMonoid MimeList

914deriving instance SwaggerMonoid URL

952deriving instance SwaggerMonoid URL

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

1050 toJSON = sopSwaggerGenericToJSON

1088 toJSON = sopSwaggerGenericToJSON

1051 DEFINE_TOENCODING

1089 DEFINE_TOENCODING

1052

1090

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

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

1093+--

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

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

1096+--

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

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

1054 toJSON (SwaggerItemsPrimitive fmt schema) = object

1098 toJSON (SwaggerItemsPrimitive fmt schema) = object

1055 [ "collectionFormat" .= fmt

1099 [ "collectionFormat" .= fmt

1056 , "items" .= schema ]

1100 , "items" .= schema ]

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

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

1102+ toJSON (SwaggerItemsArray []) = object

1103+ [ "items" .= object []

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

1105+ , "example" .= Array mempty

1106+ ]

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

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

1059

1108

1060instance ToJSON Host where

1109instance ToJSON Host where

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

1097instance ToJSON Example where

1146instance ToJSON Example where

1098 toJSON = toJSON . Map.mapKeys show . getExample

1147 toJSON = toJSON . Map.mapKeys show . getExample

1099

1148

1149+instance ToJSON SecurityDefinitions where

1150+ toJSON (SecurityDefinitions sd) = toJSON sd

1151+

1100instance ToJSON Reference where

1152instance ToJSON Reference where

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

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

1102

1154

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

1171 parseJSON = sopSwaggerGenericParseJSON

1223 parseJSON = sopSwaggerGenericParseJSON

1172

1224

1173instance FromJSON Schema where

1225instance FromJSON Schema where

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

1175

1233

1176instance FromJSON Header where

1234instance FromJSON Header where

1177 parseJSON = sopSwaggerGenericParseJSON

1235 parseJSON = sopSwaggerGenericParseJSON

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

1186 <$> o .:? "collectionFormat"

1244 <$> o .:? "collectionFormat"

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

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

1188

1246

1247+-- |

1248+--

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

1250+-- Just (SwaggerItemsArray [])

1251+--

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

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

1254+--

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

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

1257+--

1189instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1258instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1259+ parseJSON js@(Object obj)

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

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

1261+ | otherwise = SwaggerItemsObject <$> parseJSON js

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

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

1192 parseJSON _ = empty

1263 parseJSON _ = empty

1193

1264

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

1239instance FromJSON PathItem where

1310instance FromJSON PathItem where

1240 parseJSON = sopSwaggerGenericParseJSON

1311 parseJSON = sopSwaggerGenericParseJSON

1241

1312

1313+instance FromJSON SecurityDefinitions where

1314+ parseJSON js = SecurityDefinitions <$> parseJSON js

1315+

1242instance FromJSON Reference where

1316instance FromJSON Reference where

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

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

1244 parseJSON _ = empty

1318 parseJSON _ = empty

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

1350instance AesonDefaultValue MimeList where defaultValue = Just mempty

1424instance AesonDefaultValue MimeList where defaultValue = Just mempty

1351instance AesonDefaultValue Info

1425instance AesonDefaultValue Info

1352instance AesonDefaultValue ParamLocation

1426instance AesonDefaultValue ParamLocation

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

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

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

44import qualified Data.HashMap.Strict as HM

45import qualified Data.Set as Set

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

47+import qualified Data.HashSet.InsOrd as InsOrdHS

48#if MIN_VERSION_aeson(0,10,0)

49#if MIN_VERSION_aeson(0,10,0)

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

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

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

67makeLenses ''SwaggerAesonOptions

68makeLenses ''SwaggerAesonOptions

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

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

70− swaggerAesonOptions :: proxy a -> SwaggerAesonOptions

71+ swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

72 -- So far we use only default definitions

73 -- So far we use only default definitions

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

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

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

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

76-------------------------------------------------------------------------------

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

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

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

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

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

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

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

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

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

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

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

90-------------------------------------------------------------------------------

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

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

144 -> DatatypeInfo '[xs]

146 -> DatatypeInfo '[xs]

145 -> POP Maybe '[xs]

147 -> POP Maybe '[xs]

146 -> [Pair]

148 -> [Pair]

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

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

151+#else

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

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

153+#endif

148 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

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

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

150

156

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

220 -> DatatypeInfo '[xs]

226 -> DatatypeInfo '[xs]

221 -> POP Maybe '[xs]

227 -> POP Maybe '[xs]

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

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

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

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

231+#else

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

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

233+#endif

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

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

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

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

226

236

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

292 -> DatatypeInfo '[xs]

302 -> DatatypeInfo '[xs]

293 -> POP Maybe '[xs]

303 -> POP Maybe '[xs]

294 -> Series

304 -> Series

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

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

307+#else

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

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

309+#endif

296 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

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

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

298

312

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

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

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

60binaryParamSchema :: ParamSchema t

61binaryParamSchema = mempty

62− & type_ .~ SwaggerString

62+ & type_ ?~ SwaggerString

63 & format ?~ "binary"

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

66byteParamSchema :: ParamSchema t

67byteParamSchema = mempty

68− & type_ .~ SwaggerString

68+ & type_ ?~ SwaggerString

69 & format ?~ "byte"

71-- | Default schema for password string.

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

73passwordParamSchema :: ParamSchema t

74passwordParamSchema = mempty

75− & type_ .~ SwaggerString

75+ & type_ ?~ SwaggerString

76 & format ?~ "password"

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

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

88--

89-- instance ToParamSchema Direction where

90-- toParamSchema _ = mempty

91−-- & type_ .~ SwaggerString

91+-- & type_ ?~ SwaggerString

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

93-- @

94--

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

115 --

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

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

118− toParamSchema :: proxy a -> ParamSchema t

118+ toParamSchema :: Proxy a -> ParamSchema t

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

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

120 toParamSchema = genericToParamSchema defaultSchemaOptions

121

122instance OVERLAPPING_ ToParamSchema String where

123− toParamSchema _ = mempty & type_ .~ SwaggerString

123+ toParamSchema _ = mempty & type_ ?~ SwaggerString

124

125instance ToParamSchema Bool where

126− toParamSchema _ = mempty & type_ .~ SwaggerBoolean

126+ toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

127

128instance ToParamSchema Integer where

129− toParamSchema _ = mempty & type_ .~ SwaggerInteger

129+ toParamSchema _ = mempty & type_ ?~ SwaggerInteger

130

131instance ToParamSchema Natural where

132 toParamSchema _ = mempty

133− & type_ .~ SwaggerInteger

133+ & type_ ?~ SwaggerInteger

134 & minimum_ ?~ 0

135 & exclusiveMinimum ?~ False

136

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

154--

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

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

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

158toParamSchemaBoundedIntegral _ = mempty

159− & type_ .~ SwaggerInteger

159+ & type_ ?~ SwaggerInteger

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

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

162

163instance ToParamSchema Char where

164 toParamSchema _ = mempty

165− & type_ .~ SwaggerString

165+ & type_ ?~ SwaggerString

166 & maxLength ?~ 1

167 & minLength ?~ 1

168

169instance ToParamSchema Scientific where

170− toParamSchema _ = mempty & type_ .~ SwaggerNumber

170+ toParamSchema _ = mempty & type_ ?~ SwaggerNumber

171

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

173 toParamSchema _ = mempty

174− & type_ .~ SwaggerNumber

174+ & type_ ?~ SwaggerNumber

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

176

177instance ToParamSchema Double where

178 toParamSchema _ = mempty

179− & type_ .~ SwaggerNumber

179+ & type_ ?~ SwaggerNumber

180 & format ?~ "double"

181

182instance ToParamSchema Float where

183 toParamSchema _ = mempty

184− & type_ .~ SwaggerNumber

184+ & type_ ?~ SwaggerNumber

185 & format ?~ "float"

186

187timeParamSchema :: String -> ParamSchema t

188timeParamSchema fmt = mempty

189− & type_ .~ SwaggerString

189+ & type_ ?~ SwaggerString

190 & format ?~ T.pack fmt

191

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

193instance ToParamSchema Day where

194 toParamSchema _ = timeParamSchema "date"

195

196+-- |

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

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

199+instance ToParamSchema TimeOfDay where

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

201+

196-- |

202-- |

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

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

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

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

@@ -222,12 +228,12 @@ instance ToParamSchema TL.Text where

222

228

223instance ToParamSchema Version where

229instance ToParamSchema Version where

224 toParamSchema _ = mempty

230 toParamSchema _ = mempty

225− & type_ .~ SwaggerString

231+ & type_ ?~ SwaggerString

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

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

227

233

228instance ToParamSchema SetCookie where

234instance ToParamSchema SetCookie where

229 toParamSchema _ = mempty

235 toParamSchema _ = mempty

230− & type_ .~ SwaggerString

236+ & type_ ?~ SwaggerString

231

237

232

238

233#if __GLASGOW_HASKELL__ < 800

239#if __GLASGOW_HASKELL__ < 800

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

254

260

255instance ToParamSchema a => ToParamSchema [a] where

261instance ToParamSchema a => ToParamSchema [a] where

256 toParamSchema _ = mempty

262 toParamSchema _ = mempty

257− & type_ .~ SwaggerArray

263+ & type_ ?~ SwaggerArray

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

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

259

265

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

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

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

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

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

275instance ToParamSchema () where

281instance ToParamSchema () where

276 toParamSchema _ = mempty

282 toParamSchema _ = mempty

277− & type_ .~ SwaggerString

283+ & type_ ?~ SwaggerString

278 & enum_ ?~ ["_"]

284 & enum_ ?~ ["_"]

279

285

280instance ToParamSchema UUID where

286instance ToParamSchema UUID where

281 toParamSchema _ = mempty

287 toParamSchema _ = mempty

282− & type_ .~ SwaggerString

288+ & type_ ?~ SwaggerString

283 & format ?~ "uuid"

289 & format ?~ "uuid"

284

290

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

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

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

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

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

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

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

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

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

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

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

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

293

299

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

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

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

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

296

302

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

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

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

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

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

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

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

311

317

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

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

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

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

314

320

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

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

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

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

317

323

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

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

319 genumParamSchema opts _ s = s

325 genumParamSchema opts _ s = s

320− & type_ .~ SwaggerString

326+ & type_ ?~ SwaggerString

321 & enum_ %~ addEnumValue tag

327 & enum_ %~ addEnumValue tag

322 where

328 where

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

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

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

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

111-- declareNamedSchema _ = do

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

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

114−-- & type_ .~ SwaggerObject

114+-- & type_ ?~ SwaggerObject

115-- & properties .~

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

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

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

142 -- together with all used definitions.

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

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

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

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

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

148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

149

150+instance ToSchema TimeOfDay where

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

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

153+

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

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

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

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

152declareSchema = fmap _namedSchemaSchema . declareNamedSchema

156declareSchema = fmap _namedSchemaSchema . declareNamedSchema

153

157

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

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

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

162-- Just "Day"

166-- Just "Day"

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

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

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

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

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

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

166toNamedSchema = undeclare . declareNamedSchema

170toNamedSchema = undeclare . declareNamedSchema

167

171

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

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

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

172--

176--

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

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

174-- Just "UTCTime"

178-- Just "UTCTime"

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

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

176schemaName = _namedSchemaName . toNamedSchema

180schemaName = _namedSchemaName . toNamedSchema

177

181

178-- | Convert a type into a schema.

182-- | Convert a type into a schema.

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

182--

186--

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

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

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

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

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

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

186toSchema = _namedSchemaSchema . toNamedSchema

190toSchema = _namedSchemaSchema . toNamedSchema

187

191

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

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

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

193--

197--

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

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

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

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

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

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

197toSchemaRef = undeclare . declareSchemaRef

201toSchemaRef = undeclare . declareSchemaRef

198

202

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

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

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

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

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

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

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

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

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

207declareSchemaRef proxy = do

211declareSchemaRef proxy = do

208 case toNamedSchema proxy of

212 case toNamedSchema proxy of

209 NamedSchema (Just name) schema -> do

213 NamedSchema (Just name) schema -> do

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

265--

269--

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

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

267-- when inlining recursive schemas.

271-- when inlining recursive schemas.

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

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

269toInlinedSchema proxy = inlineAllSchemas defs schema

273toInlinedSchema proxy = inlineAllSchemas defs schema

270 where

274 where

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

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

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

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

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

295binarySchema :: Schema

299binarySchema :: Schema

296binarySchema = mempty

300binarySchema = mempty

297− & type_ .~ SwaggerString

301+ & type_ ?~ SwaggerString

298 & format ?~ "binary"

302 & format ?~ "binary"

299

303

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

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

301byteSchema :: Schema

305byteSchema :: Schema

302byteSchema = mempty

306byteSchema = mempty

303− & type_ .~ SwaggerString

307+ & type_ ?~ SwaggerString

304 & format ?~ "byte"

308 & format ?~ "byte"

305

309

306-- | Default schema for password string.

310-- | Default schema for password string.

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

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

308passwordSchema :: Schema

312passwordSchema :: Schema

309passwordSchema = mempty

313passwordSchema = mempty

310− & type_ .~ SwaggerString

314+ & type_ ?~ SwaggerString

311 & format ?~ "password"

315 & format ?~ "password"

312

316

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

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

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

333 sketch js@(Bool _) = go js

337 sketch js@(Bool _) = go js

334 sketch js = go js & example ?~ js

338 sketch js = go js & example ?~ js

335

339

336− go Null = mempty & type_ .~ SwaggerNull

340+ go Null = mempty & type_ ?~ SwaggerNull

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

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

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

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

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

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

340 go (Array xs) = mempty

344 go (Array xs) = mempty

341− & type_ .~ SwaggerArray

345+ & type_ ?~ SwaggerArray

342 & items ?~ case ischema of

346 & items ?~ case ischema of

343 Just s -> SwaggerItemsObject (Inline s)

347 Just s -> SwaggerItemsObject (Inline s)

344 _ -> SwaggerItemsArray (map Inline ys)

348 _ -> SwaggerItemsArray (map Inline ys)

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

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

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

351 _ -> Nothing

355 _ -> Nothing

352 go (Object o) = mempty

356 go (Object o) = mempty

353− & type_ .~ SwaggerObject

357+ & type_ ?~ SwaggerObject

354 & required .~ HashMap.keys o

358 & required .~ HashMap.keys o

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

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

356

360

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

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

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

374sketchStrictSchema = go . toJSON

378sketchStrictSchema = go . toJSON

375 where

379 where

376− go Null = mempty & type_ .~ SwaggerNull

380+ go Null = mempty & type_ ?~ SwaggerNull

377 go js@(Bool _) = mempty

381 go js@(Bool _) = mempty

378− & type_ .~ SwaggerBoolean

382+ & type_ ?~ SwaggerBoolean

379 & enum_ ?~ [js]

383 & enum_ ?~ [js]

380 go js@(String s) = mempty

384 go js@(String s) = mempty

381− & type_ .~ SwaggerString

385+ & type_ ?~ SwaggerString

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

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

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

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

384 & pattern ?~ s

388 & pattern ?~ s

385 & enum_ ?~ [js]

389 & enum_ ?~ [js]

386 go js@(Number n) = mempty

390 go js@(Number n) = mempty

387− & type_ .~ SwaggerNumber

391+ & type_ ?~ SwaggerNumber

388 & maximum_ ?~ n

392 & maximum_ ?~ n

389 & minimum_ ?~ n

393 & minimum_ ?~ n

390 & multipleOf ?~ n

394 & multipleOf ?~ n

391 & enum_ ?~ [js]

395 & enum_ ?~ [js]

392 go js@(Array xs) = mempty

396 go js@(Array xs) = mempty

393− & type_ .~ SwaggerArray

397+ & type_ ?~ SwaggerArray

394 & maxItems ?~ fromIntegral sz

398 & maxItems ?~ fromIntegral sz

395 & minItems ?~ fromIntegral sz

399 & minItems ?~ fromIntegral sz

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

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

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

400 sz = length xs

404 sz = length xs

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

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

402 go js@(Object o) = mempty

406 go js@(Object o) = mempty

403− & type_ .~ SwaggerObject

407+ & type_ ?~ SwaggerObject

404 & required .~ names

408 & required .~ names

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

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

406 & maxProperties ?~ fromIntegral (length names)

410 & maxProperties ?~ fromIntegral (length names)

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

410 names = HashMap.keys o

414 names = HashMap.keys o

411

415

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

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

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

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

414

418

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

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

416 declareNamedSchema _ = do

420 declareNamedSchema _ = do

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

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

418 return $ unnamed $ mempty

422 return $ unnamed $ mempty

419− & type_ .~ SwaggerArray

423+ & type_ ?~ SwaggerArray

420 & items ?~ SwaggerItemsObject ref

424 & items ?~ SwaggerItemsObject ref

421

425

422instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

426instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

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

466

470

467timeSchema :: T.Text -> Schema

471timeSchema :: T.Text -> Schema

468timeSchema fmt = mempty

472timeSchema fmt = mempty

469− & type_ .~ SwaggerString

473+ & type_ ?~ SwaggerString

470 & format ?~ fmt

474 & format ?~ fmt

471

475

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

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

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

528 declareObjectMapSchema = do

532 declareObjectMapSchema = do

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

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

530 return $ unnamed $ mempty

534 return $ unnamed $ mempty

531− & type_ .~ SwaggerObject

535+ & type_ ?~ SwaggerObject

532 & additionalProperties ?~ AdditionalPropertiesSchema schema

536 & additionalProperties ?~ AdditionalPropertiesSchema schema

533

537

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

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

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

540 declareNamedSchema _ = do

544 declareNamedSchema _ = do

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

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

542 return $ unnamed $ mempty

546 return $ unnamed $ mempty

543− & type_ .~ SwaggerObject

547+ & type_ ?~ SwaggerObject

544 & additionalProperties ?~ schema

548 & additionalProperties ?~ schema

545

549

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

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

@@ -554,7 +558,7 @@ instance ToSchema a => ToSchema (HashMap TL.Text a) where declareNamedSchema _ =

554

558

555instance OVERLAPPING_ ToSchema Object where

559instance OVERLAPPING_ ToSchema Object where

556 declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty

560 declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty

557− & type_ .~ SwaggerObject

561+ & type_ ?~ SwaggerObject

558 & description ?~ "Arbitrary JSON object."

562 & description ?~ "Arbitrary JSON object."

559 & additionalProperties ?~ AdditionalPropertiesAllowed True

563 & additionalProperties ?~ AdditionalPropertiesAllowed True

560

564

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

593--

597--

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

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

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

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

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

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

597toSchemaBoundedIntegral _ = mempty

601toSchemaBoundedIntegral _ = mempty

598− & type_ .~ SwaggerInteger

602+ & type_ ?~ SwaggerInteger

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

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

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

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

601

605

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

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

603−genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

607+genericToNamedSchemaBoundedIntegral :: forall a d f.

604 ( Bounded a, Integral a

608 ( Bounded a, Integral a

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

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

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

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

607genericToNamedSchemaBoundedIntegral opts proxy

611genericToNamedSchemaBoundedIntegral opts proxy

608 = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

612 = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

609

613

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

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

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

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

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

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

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

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

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

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

615− -> proxy a

619+ -> Proxy a

616 -> Declare (Definitions Schema) NamedSchema

620 -> Declare (Definitions Schema) NamedSchema

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

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

618

622

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

629--

633--

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

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

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

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

632−declareSchemaBoundedEnumKeyMapping :: forall map key value proxy.

636+declareSchemaBoundedEnumKeyMapping :: forall map key value.

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

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

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

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

635declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

639declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

636 ToJSONKeyText keyToText _ -> objectSchema keyToText

640 ToJSONKeyText keyToText _ -> objectSchema keyToText

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

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

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

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

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

642 mkPair k = (keyToText k, valueRef)

646 mkPair k = (keyToText k, valueRef)

643 return $ mempty

647 return $ mempty

644− & type_ .~ SwaggerObject

648+ & type_ ?~ SwaggerObject

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

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

646

650

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

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

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

657--

661--

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

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

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

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

660−toSchemaBoundedEnumKeyMapping :: forall map key value proxy.

664+toSchemaBoundedEnumKeyMapping :: forall map key value.

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

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

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

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

663toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

667toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

664

668

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

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

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

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

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

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

668genericDeclareSchema = genericDeclareSchemaUnrestricted

672genericDeclareSchema = genericDeclareSchemaUnrestricted

669

673

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

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

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

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

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

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

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

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

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

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

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

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

676genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

680genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

677

681

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

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

679--

683--

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

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

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

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

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

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

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

684

688

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

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

686--

690--

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

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

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

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

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

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

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

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

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

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

692

696

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

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

694−genericNameSchema :: forall a d f proxy.

698+genericNameSchema :: forall a d f.

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

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

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

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

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

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

698

702

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

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

700gdatatypeSchemaName opts _ = case orig of

704gdatatypeSchemaName opts _ = case orig of

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

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

702 _ -> Nothing

706 _ -> Nothing

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

705 name = datatypeNameModifier opts orig

709 name = datatypeNameModifier opts orig

706

710

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

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

708−paramSchemaToNamedSchema :: forall a d f proxy.

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

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

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

713+ SchemaOptions -> Proxy a -> NamedSchema

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

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

712

715

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

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

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

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

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

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

716

719

717nullarySchema :: Schema

720nullarySchema :: Schema

718nullarySchema = mempty

721nullarySchema = mempty

719− & type_ .~ SwaggerArray

722+ & type_ ?~ SwaggerArray

720 & items ?~ SwaggerItemsArray []

723 & items ?~ SwaggerItemsArray []

721

724

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

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

723gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

726gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

724

727

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

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

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

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

727

730

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

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

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

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

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

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

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

758

761

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

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

760gdeclareSchemaRef opts proxy = do

763gdeclareSchemaRef opts proxy = do

761 case gtoNamedSchema opts proxy of

764 case gtoNamedSchema opts proxy of

762 NamedSchema (Just name) schema -> do

765 NamedSchema (Just name) schema -> do

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

787 return $

790 return $

788 if T.null fname

791 if T.null fname

789 then schema

792 then schema

790− & type_ .~ SwaggerArray

793+ & type_ ?~ SwaggerArray

791 & items %~ appendItem ref

794 & items %~ appendItem ref

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

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

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

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

794 else schema

797 else schema

795− & type_ .~ SwaggerObject

798+ & type_ ?~ SwaggerObject

796 & properties . at fname ?~ ref

799 & properties . at fname ?~ ref

797 & if isRequiredField

800 & if isRequiredField

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

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

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

820 where

823 where

821 gdeclareNamedSchema = gdeclareNamedSumSchema

824 gdeclareNamedSchema = gdeclareNamedSumSchema

822

825

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

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

824gdeclareNamedSumSchema opts proxy s

827gdeclareNamedSumSchema opts proxy s

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

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

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

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

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

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

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

830

833

831 toStringTag schema = mempty

834 toStringTag schema = mempty

832− & type_ .~ SwaggerString

835+ & type_ ?~ SwaggerString

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

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

834

837

835type AllNullary = All

838type AllNullary = All

836

839

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

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

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

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

839

842

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

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

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

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

842

845

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

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

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

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

845gsumConToSchemaWith ref opts _ schema = schema

848gsumConToSchemaWith ref opts _ schema = schema

846− & type_ .~ SwaggerObject

849+ & type_ ?~ SwaggerObject

847 & properties . at tag ?~ ref

850 & properties . at tag ?~ ref

848 & maxProperties ?~ 1

851 & maxProperties ?~ 1

849 & minProperties ?~ 1

852 & minProperties ?~ 1

850 where

853 where

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

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

852

855

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

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

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

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

855gsumConToSchema opts proxy schema = do

858gsumConToSchema opts proxy schema = do

856 ref <- gdeclareSchemaRef opts proxy

859 ref <- gdeclareSchemaRef opts proxy

857 return $ gsumConToSchemaWith ref opts proxy schema

860 return $ gsumConToSchemaWith ref opts proxy schema

src/Data/Swagger/Internal/Schema/Validation.hs+207−49

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

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE DataKinds #-}

1−{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE DeriveFunctor #-}

2−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE PackageImports #-}

10+{-# LANGUAGE PackageImports #-}

9−{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TemplateHaskell #-}

13+{-# LANGUAGE TemplateHaskell #-}

12−{-# LANGUAGE UndecidableInstances #-}

14+{-# LANGUAGE UndecidableInstances #-}

13-- |

15-- |

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

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

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

20-- Validate JSON values with Swagger Schema.

22-- Validate JSON values with Swagger Schema.

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

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

23−import Control.Applicative

25+import Prelude ()

24−import Control.Lens

26+import Prelude.Compat

25−import Control.Monad (when)

28+import Control.Applicative

29+import Control.Lens

30+import Control.Monad (when)

31+

27−import Data.Aeson hiding (Result)

32+import Data.Aeson hiding (Result)

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

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

34+import Data.Foldable (for_, sequenceA_,

35+ traverse_)

29−import Data.HashMap.Strict (HashMap)

36+import Data.HashMap.Strict (HashMap)

30−import qualified Data.HashMap.Strict as HashMap

37+import qualified Data.HashMap.Strict as HashMap

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

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

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

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

33−import Data.Monoid

34−import Data.Proxy

40+import Data.Proxy

35−import Data.Scientific (Scientific, isInteger)

41+import Data.Scientific (Scientific, isInteger)

36−import Data.Text (Text)

42+import Data.Text (Text)

37−import qualified Data.Text as Text

43+import qualified Data.Text as Text

44+import qualified Data.Text.Lazy as TL

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

38−import Data.Vector (Vector)

46+import Data.Vector (Vector)

39−import qualified Data.Vector as Vector

47+import qualified Data.Vector as Vector

40−

48+

41−import Data.Swagger.Declare

49+import Data.Swagger.Declare

42−import Data.Swagger.Internal

50+import Data.Swagger.Internal

43−import Data.Swagger.Internal.Schema

51+import Data.Swagger.Internal.Schema

44−import Data.Swagger.Lens

52+import Data.Swagger.Lens

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

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

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

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

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

50--

58--

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

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

52-- See @'validateToJSONWithPatternChecker'@.

60-- See @'validateToJSONWithPatternChecker'@.

61+--

62+-- See 'renderValidationErrors' on how the output is structured.

63+validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String

64+validatePrettyToJSON = renderValidationErrors validateToJSON

65+

66+-- | Variant of 'validatePrettyToJSON' with typed output.

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

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

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

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

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

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

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

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

58--

72--

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

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

74+-- 'renderValidationErrors'.

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

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

61validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

76validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

62 where

77 where

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

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

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+

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

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

66--

157--

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

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

@@ -320,8 +411,8 @@ validateObject o = withSchema $ \sch ->

320 validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v

411 validateAdditional _ v (AdditionalPropertiesSchema s) = validateWithSchemaRef s v

321

412

322 unknownProperty :: Text -> Validation s a

413 unknownProperty :: Text -> Validation s a

323− unknownProperty name = invalid $

414+ unknownProperty pname = invalid $

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

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

325

416

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

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

327validateEnum value = do

418validateEnum value = do

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

329 when (value `notElem` xs) $

420 when (value `notElem` xs) $

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

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

331

422

423+-- | Infer schema type based on used properties.

424+--

425+-- This is like 'inferParamSchemaTypes', but also works for objects:

426+--

427+-- >>> inferSchemaTypes <$> decode "{\"minProperties\": 1}"

428+-- Just [SwaggerObject]

429+inferSchemaTypes :: Schema -> [SwaggerType 'SwaggerKindSchema]

430+inferSchemaTypes sch = inferParamSchemaTypes (sch ^. paramSchema) ++

431+ [ SwaggerObject | any ($ sch)

432+ [ has (additionalProperties._Just)

433+ , has (maxProperties._Just)

434+ , has (minProperties._Just)

435+ , has (properties.folded)

436+ , has (required.folded) ] ]

437+

438+-- | Infer schema type based on used properties.

439+--

440+-- >>> inferSchemaTypes <$> decode "{\"minLength\": 2}"

441+-- Just [SwaggerString]

442+--

443+-- >>> inferSchemaTypes <$> decode "{\"maxItems\": 0}"

444+-- Just [SwaggerArray]

445+--

446+-- From numeric properties 'SwaggerInteger' type is inferred.

447+-- If you want 'SwaggerNumber' instead, you must specify it explicitly.

448+--

449+-- >>> inferSchemaTypes <$> decode "{\"minimum\": 1}"

450+-- Just [SwaggerInteger]

451+inferParamSchemaTypes :: ParamSchema t -> [SwaggerType t]

452+inferParamSchemaTypes sch = concat

453+ [ [ SwaggerArray | any ($ sch)

454+ [ has (items._Just)

455+ , has (maxItems._Just)

456+ , has (minItems._Just)

457+ , has (uniqueItems._Just) ] ]

458+ , [ SwaggerInteger | any ($ sch)

459+ [ has (exclusiveMaximum._Just)

460+ , has (exclusiveMinimum._Just)

461+ , has (maximum_._Just)

462+ , has (minimum_._Just)

463+ , has (multipleOf._Just) ] ]

464+ , [ SwaggerString | any ($ sch)

465+ [ has (maxLength._Just)

466+ , has (minLength._Just)

467+ , has (pattern._Just) ] ]

468+ ]

469+

332validateSchemaType :: Value -> Validation Schema ()

470validateSchemaType :: Value -> Validation Schema ()

333validateSchemaType value = withSchema $ \sch ->

471validateSchemaType value = withSchema $ \sch ->

334 case (sch ^. type_, value) of

472 case (sch ^. type_, value) of

335− (SwaggerNull, Null) -> valid

473+ (Just SwaggerNull, Null) -> valid

336− (SwaggerBoolean, Bool _) -> valid

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

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

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

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

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

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

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

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

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

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

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

480+ (Nothing, Null) -> valid

481+ (Nothing, Bool _) -> valid

482+ -- Number by default

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

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

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

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

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

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

343

488

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

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

345validateParamSchemaType value = withSchema $ \sch ->

490validateParamSchemaType value = withSchema $ \sch ->

346 case (sch ^. type_, value) of

491 case (sch ^. type_, value) of

347− (SwaggerBoolean, Bool _) -> valid

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

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

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

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

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

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

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

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

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

497+ (Nothing, Bool _) -> valid

498+ -- Number by default

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

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

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

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

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

353−

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/Lens.hs+10−4

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

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

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

99+type instance Index SecurityDefinitions = Text

100+type instance IxValue SecurityDefinitions = SecurityScheme

101+

102+instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n

103+instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n

104+

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

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

100

106

101-- HasType instances

107-- HasType instances

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

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

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

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

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

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

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

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

106

112

107-- HasDefault instances

113-- HasDefault instances

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

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

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

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

37import Data.Data.Lens

38import Data.List.Compat

39import Data.Maybe (mapMaybe)

40+import Data.Proxy

40import qualified Data.Set as Set

41import qualified Data.Set as Set

42import Data.Swagger.Declare

43import Data.Swagger.Declare

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

45import Data.Swagger.Schema

46import Data.Swagger.Schema

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

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

49+import qualified Data.HashSet.InsOrd as InsOrdHS

49-- $setup

51-- $setup

50-- >>> import Data.Aeson

52-- >>> import Data.Aeson

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

110-- list of tags.

112-- list of tags.

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

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

112applyTagsFor ops ts swag = swag

114applyTagsFor ops ts swag = swag

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

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

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

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

115

117

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

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

117-- necessary schema definitions.

119-- necessary schema definitions.

118--

120--

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

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

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

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

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

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

122declareResponse proxy = do

124declareResponse proxy = do

123 s <- declareSchemaRef proxy

125 s <- declareSchemaRef proxy

124 return (mempty & schema ?~ s)

126 return (mempty & schema ?~ s)

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

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

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

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

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

191 combine Nothing = new

193 combine Nothing = new

192−

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.hs+22−14

@@ -4,47 +4,55 @@

5module Data.Swagger.Schema.Generator where

7−import Prelude ()

7+import Prelude ()

8import Prelude.Compat

10import Control.Lens.Operators

11−import Control.Monad (filterM)

11+import Control.Monad (filterM)

12import Data.Aeson

13import Data.Aeson.Types

14−import qualified Data.HashMap.Strict.InsOrd as M

14+import qualified Data.HashMap.Strict.InsOrd as M

15import Data.Maybe

16import Data.Maybe

17import Data.Proxy

18import Data.Scientific

19−import qualified Data.Set as S

19+import qualified Data.Set as S

20import Data.Swagger

21import Data.Swagger.Declare

22+import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)

22−import qualified Data.Text as T

23+import qualified Data.Text as T

23−import qualified Data.Vector as V

24+import qualified Data.Vector as V

24−import Test.QuickCheck (arbitrary)

25+import Test.QuickCheck (arbitrary)

25import Test.QuickCheck.Gen

26import Test.QuickCheck.Gen

26import Test.QuickCheck.Property

27import Test.QuickCheck.Property

29+-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30+-- and cannot be inferred.

28schemaGen :: Definitions Schema -> Schema -> Gen Value

31schemaGen :: Definitions Schema -> Schema -> Gen Value

29schemaGen _ schema

32schemaGen _ schema

30 | Just cases <- schema ^. paramSchema . enum_ = elements cases

33 | Just cases <- schema ^. paramSchema . enum_ = elements cases

31schemaGen defns schema =

34schemaGen defns schema =

32 case schema ^. type_ of

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"

33− SwaggerBoolean -> Bool <$> elements [True, False]

41+ Just SwaggerBoolean -> Bool <$> elements [True, False]

34− SwaggerNull -> pure Null

42+ Just SwaggerNull -> pure Null

35− SwaggerNumber

43+ Just SwaggerNumber

36 | Just min <- schema ^. minimum_

44 | Just min <- schema ^. minimum_

37 , Just max <- schema ^. maximum_ ->

45 , Just max <- schema ^. maximum_ ->

38 Number . fromFloatDigits <$>

46 Number . fromFloatDigits <$>

39 choose (toRealFloat min, toRealFloat max :: Double)

47 choose (toRealFloat min, toRealFloat max :: Double)

40 | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

48 | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

41− SwaggerInteger

49+ Just SwaggerInteger

42 | Just min <- schema ^. minimum_

50 | Just min <- schema ^. minimum_

43 , Just max <- schema ^. maximum_ ->

51 , Just max <- schema ^. maximum_ ->

44 Number . fromInteger <$>

52 Number . fromInteger <$>

45 choose (truncate min, truncate max)

53 choose (truncate min, truncate max)

46 | otherwise -> Number . fromInteger <$> arbitrary

54 | otherwise -> Number . fromInteger <$> arbitrary

47− SwaggerArray

55+ Just SwaggerArray

48 | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

56 | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

49 | Just items <- schema ^. items ->

57 | Just items <- schema ^. items ->

50 case items of

58 case items of

@@ -59,14 +67,14 @@ schemaGen defns schema =

59 SwaggerItemsArray refs ->

67 SwaggerItemsArray refs ->

60 let itemGens = schemaGen defns . dereference defns <$> refs

68 let itemGens = schemaGen defns . dereference defns <$> refs

61 in fmap (Array . V.fromList) $ sequence itemGens

69 in fmap (Array . V.fromList) $ sequence itemGens

62− SwaggerString -> do

70+ Just SwaggerString -> do

63 size <- getSize

71 size <- getSize

64 let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

72 let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

65 let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

73 let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

66 length <- choose (minLength', max minLength' maxLength')

74 length <- choose (minLength', max minLength' maxLength')

67 str <- vectorOf length arbitrary

75 str <- vectorOf length arbitrary

68 return . String $ T.pack str

76 return . String $ T.pack str

69− SwaggerObject -> do

77+ Just SwaggerObject -> do

70 size <- getSize

78 size <- getSize

71 let props = dereference defns <$> schema ^. properties

79 let props = dereference defns <$> schema ^. properties

72 reqKeys = S.fromList $ schema ^. required

80 reqKeys = S.fromList $ schema ^. required

src/Data/Swagger/Schema/Validation.hs+2

@@ -19,8 +19,10 @@ module Data.Swagger.Schema.Validation (

19 ValidationError,

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

22+ validatePrettyToJSON,

22 validateToJSON,

23 validateToJSON,

23 validateToJSONWithPatternChecker,

24 validateToJSONWithPatternChecker,

25+ renderValidationErrors,

25 -- ** Using 'Value' and 'Schema'

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

26 validateJSON,

28 validateJSON,

stack.yaml+6−3

@@ -1,6 +1,9 @@

1−resolver: lts-12.10

1+resolver: lts-14.3

2packages:

3- '.'

4extra-deps:

5−- base-compat-batteries-0.10.4

5+- optics-core-0.2

6−- contravariant-1.5

6+- optics-th-0.2

7+- optics-extra-0.2

8+- indexed-profunctors-0.1

9+- insert-ordered-containers-0.2.3

swagger2.cabal+25−25

@@ -1,12 +1,11 @@

1cabal-version: >=1.10

2name: swagger2

3−version: 2.3.0.1

3+version: 2.5

4−x-revision: 2

6synopsis: Swagger 2.0 data model

5synopsis: Swagger 2.0 data model

7category: Web, Swagger

6category: Web, Swagger

8description:

7description:

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

10 specifications as well as manipulating them.

9 specifications as well as manipulating them.

11 .

10 .

12 The original Swagger 2.0 specification is available at http://swagger.io/specification/.

11 The original Swagger 2.0 specification is available at http://swagger.io/specification/.

@@ -25,16 +24,15 @@ extra-source-files:

25 , examples/*.hs

24 , examples/*.hs

26 , include/overlapping-compat.h

25 , include/overlapping-compat.h

27tested-with:

26tested-with:

28− GHC ==7.8.4

29− || ==7.10.3

30− || ==8.0.2

27+ GHC ==8.0.2

31 || ==8.2.2

28 || ==8.2.2

32 || ==8.4.4

29 || ==8.4.4

33− || ==8.6.1

30+ || ==8.6.5

31+ || ==8.8.1

35custom-setup

33custom-setup

36 setup-depends:

34 setup-depends:

37− base, Cabal, cabal-doctest >=1.0.2 && <1.1

35+ base, Cabal, cabal-doctest >=1.0.6 && <1.1

39library

37library

40 hs-source-dirs: src

38 hs-source-dirs: src

@@ -44,6 +42,7 @@ library

44 Data.Swagger.Declare

42 Data.Swagger.Declare

45 Data.Swagger.Lens

43 Data.Swagger.Lens

46 Data.Swagger.Operation

44 Data.Swagger.Operation

45+ Data.Swagger.Optics

47 Data.Swagger.ParamSchema

46 Data.Swagger.ParamSchema

48 Data.Swagger.Schema

47 Data.Swagger.Schema

49 Data.Swagger.Schema.Generator

48 Data.Swagger.Schema.Generator

@@ -61,11 +60,12 @@ library

62 -- GHC boot libraries

61 -- GHC boot libraries

63 build-depends:

62 build-depends:

64− base >=4.7 && <4.13

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

67+ , template-haskell >=2.9.0.0 && <2.16

68− , time >=1.4.2 && <1.9

68+ , time >=1.4.2 && <1.10

69 , transformers >=0.3.0.0 && <0.6

71 build-depends:

@@ -74,22 +74,24 @@ library

75 -- other dependencies

76 build-depends:

77− base-compat-batteries >=0.10.4 && <0.11

77+ base-compat-batteries >=0.10.4 && <0.12

78− , aeson >=1.3.1.1 && <1.5

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

81+ , generics-sop >=0.3.2.0 && <0.6

82− , hashable >=1.2.7.0 && <1.3

82+ , hashable >=1.2.7.0 && <1.4

83− , http-media >=0.7.1.2 && <0.8

83+ , http-media >=0.7.1.2 && <0.9

84− , insert-ordered-containers >=0.2.1.0 && <0.3

84+ , insert-ordered-containers >=0.2.3 && <0.3

85− , lens >=4.16.1 && <4.18

85+ , lens >=4.16.1 && <4.19

86− , network >=2.6.3.5 && <2.9

86+ , network >=2.6.3.5 && <3.2

87+ , optics-core >=0.2 && <0.3

88+ , optics-th >=0.2 && <0.3

87 , scientific >=0.3.6.2 && <0.4

89 , scientific >=0.3.6.2 && <0.4

88 , transformers-compat >=0.3 && <0.7

90 , transformers-compat >=0.3 && <0.7

89 , unordered-containers >=0.2.9.0 && <0.3

91 , unordered-containers >=0.2.9.0 && <0.3

90 , uuid-types >=1.0.3 && <1.1

92 , uuid-types >=1.0.3 && <1.1

91 , vector >=0.12.0.1 && <0.13

93 , vector >=0.12.0.1 && <0.13

92− , QuickCheck >=2.10.1 && <2.12

94+ , QuickCheck >=2.10.1 && <2.14

94 default-language: Haskell2010

96 default-language: Haskell2010

@@ -116,18 +118,18 @@ test-suite spec

116 , time

118 , time

117 , unordered-containers

119 , unordered-containers

118 , vector

120 , vector

121+ , QuickCheck

119

122

120 -- test-suite only dependencies

123 -- test-suite only dependencies

121 build-depends:

124 build-depends:

122− hspec >=2.5.5 && <2.6

125+ hspec >=2.5.5 && <2.8

123 , HUnit >=1.6.0.0 && <1.7

126 , HUnit >=1.6.0.0 && <1.7

124− , QuickCheck >=2.11.3 && <2.13

125 , quickcheck-instances >=0.3.19 && <0.14

127 , quickcheck-instances >=0.3.19 && <0.14

126 , utf8-string >=1.0.1.1 && <1.1

128 , utf8-string >=1.0.1.1 && <1.1

127

129

128 -- https://github.com/haskell/cabal/issues/3708

130 -- https://github.com/haskell/cabal/issues/3708

129 build-tool-depends:

131 build-tool-depends:

130− hspec-discover:hspec-discover >=2.5.5 && <2.6

132+ hspec-discover:hspec-discover >=2.5.5 && <2.8

131

133

132 other-modules:

134 other-modules:

133 SpecCommon

135 SpecCommon

@@ -137,8 +139,6 @@ test-suite spec

137 Data.Swagger.SchemaSpec

139 Data.Swagger.SchemaSpec

138 Data.Swagger.Schema.ValidationSpec

140 Data.Swagger.Schema.ValidationSpec

139 Data.Swagger.Schema.GeneratorSpec

141 Data.Swagger.Schema.GeneratorSpec

140−

141− Data.Aeson.QQ.Simple

142 default-language: Haskell2010

143

144test-suite doctests

test/Data/Aeson/QQ/Simple.hsdeleted−45

@@ -1,45 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−-- | Like "Data.Aeson.QQ" but without interpolation.

3−module Data.Aeson.QQ.Simple where

4−

5−import Data.Aeson

6−import Data.ByteString.Lazy.UTF8 as UTF8

7−import qualified Data.HashMap.Strict as HM

8−import qualified Data.Text as T

9−import qualified Data.Vector as V

10−import Language.Haskell.TH

11−import Language.Haskell.TH.Quote

12−import Language.Haskell.TH.Syntax (Lift (..))

13−import Prelude ()

14−import Prelude.Compat

15−

16−aesonQQ :: QuasiQuoter

17−aesonQQ = QuasiQuoter

18− { quoteExp = aesonExp

19− , quotePat = const $ error "No quotePat defined for jsonQQ"

20− , quoteType = const $ error "No quoteType defined for jsonQQ"

21− , quoteDec = const $ error "No quoteDec defined for jsonQQ"

22− }

23−

24−aesonExp :: String -> ExpQ

25−aesonExp txt =

26− case eitherDecode $ UTF8.fromString txt of

27− Left err -> error $ "Error in aesonExp: " ++ show err

28− Right val -> liftValue val

29−

30−liftValue :: Value -> ExpQ

31−liftValue (String str) = [| String $(liftText str) |]

32−liftValue Null = [| Null |]

33−liftValue (Number n) = [| Number (fromRational $(return $ LitE $ RationalL (toRational n))) |]

34−liftValue (Bool b) = [| Bool b |]

35−liftValue (Array arr) = [| Array $ V.fromList $(ListE <$> traverse liftValue (V.toList arr)) |]

36−liftValue (Object obj) = [| object $jsList |]

37− where

38− jsList :: ExpQ

39− jsList = ListE <$> traverse objs2list (HM.toList obj)

40−

41− objs2list :: (T.Text, Value) -> ExpQ

42− objs2list (key, value) = [| ($(liftText key), $(liftValue value)) |]

43−

44−liftText :: T.Text -> ExpQ

45−liftText t = [| T.pack $(lift $ T.unpack t) |]

test/Data/Swagger/CommonTestTypes.hs+31−4

@@ -18,8 +18,6 @@ import qualified Data.Text as Text

18import GHC.Generics

20import Data.Swagger

21−import Data.Swagger.Declare

22−import Data.Swagger.Internal (SwaggerKind (..))

24-- ========================================================================

22-- ========================================================================

25-- Unit type

23-- Unit type

@@ -552,7 +550,7 @@ lightSchemaJSON = [aesonQQ|

552 "type": "object",

550 "type": "object",

553 "properties":

551 "properties":

554 {

552 {

555− "NoLight": { "type": "array", "items": [] },

553+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

556 "LightFreq": { "type": "number", "format": "double" },

554 "LightFreq": { "type": "number", "format": "double" },

557 "LightColor": { "$ref": "#/definitions/Color" },

555 "LightColor": { "$ref": "#/definitions/Color" },

558 "LightWaveLength": { "type": "number", "format": "double" }

556 "LightWaveLength": { "type": "number", "format": "double" }

@@ -568,7 +566,7 @@ lightInlinedSchemaJSON = [aesonQQ|

568 "type": "object",

566 "type": "object",

569 "properties":

567 "properties":

570 {

568 {

571− "NoLight": { "type": "array", "items": [] },

569+ "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

572 "LightFreq": { "type": "number", "format": "double" },

570 "LightFreq": { "type": "number", "format": "double" },

573 "LightColor":

571 "LightColor":

574 {

572 {

@@ -650,3 +648,32 @@ singleMaybeFieldSchemaJSON = [aesonQQ|

650 }

648 }

651}

649}

652|]

650|]

651+

652+

653+-- ========================================================================

654+-- TimeOfDay

655+-- ========================================================================

656+data TimeOfDay

657+ = Int

658+ | Pico

659+ deriving (Generic)

660+instance ToSchema TimeOfDay

661+instance ToParamSchema TimeOfDay

662+

663+

664+timeOfDaySchemaJSON :: Value

665+timeOfDaySchemaJSON = [aesonQQ|

666+{

667+ "example": "12:33:15",

668+ "type": "string",

669+ "format": "hh:MM:ss"

670+}

671+|]

672+

673+timeOfDayParamSchemaJSON :: Value

674+timeOfDayParamSchemaJSON = [aesonQQ|

675+{

676+ "type": "string",

677+ "format": "hh:MM:ss"

678+}

679+|]

test/Data/Swagger/ParamSchemaSpec.hs+6−1

@@ -3,9 +3,10 @@

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE QuasiQuotes #-}

6+{-# LANGUAGE OverloadedStrings #-}

6module Data.Swagger.ParamSchemaSpec where

7module Data.Swagger.ParamSchemaSpec where

8−import Data.Aeson (Value)

9+import Data.Aeson

9import Data.Aeson.QQ.Simple

10import Data.Aeson.QQ.Simple

10import Data.Char

11import Data.Char

11import Data.Proxy

12import Data.Proxy

@@ -17,6 +18,9 @@ import Data.Swagger.Internal (SwaggerKind(..))

17import Data.Swagger.CommonTestTypes

18import Data.Swagger.CommonTestTypes

18import SpecCommon

19import SpecCommon

19import Test.Hspec

20import Test.Hspec

21+import Data.Time.LocalTime

22+

23+import qualified Data.HashMap.Strict as HM

21checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

25checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

22checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

26checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

@@ -30,6 +34,7 @@ spec = do

30 context "Unary records" $ do

34 context "Unary records" $ do

31 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

35 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

32 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

36 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

34main :: IO ()

39main :: IO ()

35main = hspec spec

40main = hspec spec

test/Data/Swagger/Schema/GeneratorSpec.hs+4−4

@@ -103,7 +103,7 @@ instance FromJSON WrongType where

103instance ToSchema WrongType where

104 declareNamedSchema _ = return . NamedSchema (Just "WrongType") $

105 mempty

106− & type_ .~ SwaggerObject

106+ & type_ ?~ SwaggerObject

107

108

109data MissingRequired = MissingRequired

@@ -123,7 +123,7 @@ instance ToSchema MissingRequired where

123 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

124 return . NamedSchema (Just "MissingRequired") $

125 mempty

126− & type_ .~ SwaggerObject

126+ & type_ ?~ SwaggerObject

127 & properties .~ [("propA", stringSchema)

128 ,("propB", boolSchema)

129 ]

@@ -145,7 +145,7 @@ instance ToSchema MissingProperty where

145 stringSchema <- declareSchemaRef (Proxy :: Proxy String)

146 return . NamedSchema (Just "MissingProperty") $

147 mempty

148− & type_ .~ SwaggerObject

148+ & type_ ?~ SwaggerObject

149 & properties .~ [("propC", stringSchema)]

150 & required .~ ["propC"]

151

@@ -163,6 +163,6 @@ instance ToSchema WrongPropType where

163 boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

164 return . NamedSchema (Just "WrongPropType") $

165 mempty

166− & type_ .~ SwaggerObject

166+ & type_ ?~ SwaggerObject

167 & properties .~ [("propE", boolSchema)]

168 & required .~ ["propE"]

test/Data/Swagger/Schema/ValidationSpec.hs+1−1

@@ -248,7 +248,7 @@ instance ToJSON FreeForm where

248

249instance ToSchema FreeForm where

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

251− & type_ .~ SwaggerObject

251+ & type_ ?~ SwaggerObject

252 & additionalProperties ?~ AdditionalPropertiesAllowed True

253

254instance Arbitrary FreeForm where

test/Data/Swagger/SchemaSpec.hs+5−6

@@ -8,16 +8,11 @@ import Prelude ()

8import Prelude.Compat

10import Control.Lens ((^.))

11−import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))

11+import Data.Aeson (Value)

12−import Data.Aeson.Types (toJSONKeyText)

13−import Data.Aeson.QQ.Simple

14−import Data.Char

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

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

16import Data.Proxy

13import Data.Proxy

17import Data.Set (Set)

14import Data.Set (Set)

18−import Data.Map (Map)

19import qualified Data.Text as Text

15import qualified Data.Text as Text

20−import GHC.Generics

22import Data.Swagger

17import Data.Swagger

23import Data.Swagger.Declare

18import Data.Swagger.Declare

@@ -26,6 +21,9 @@ import Data.Swagger.CommonTestTypes

26import SpecCommon

21import SpecCommon

27import Test.Hspec

22import Test.Hspec

24+import qualified Data.HashMap.Strict as HM

25+import Data.Time.LocalTime

26+

29checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

27checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

30checkToSchema proxy js = toSchema proxy <=> js

28checkToSchema proxy js = toSchema proxy <=> js

@@ -110,6 +108,7 @@ spec = do

110 context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

108 context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

111 describe "Bounded Enum key mapping" $ do

109 describe "Bounded Enum key mapping" $ do

112 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

110 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

111+ context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON

113

112

114main :: IO ()

113main :: IO ()

115main = hspec spec

114main = hspec spec

test/Data/SwaggerSpec.hs+72−31

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

12import Data.Aeson

13import Data.Aeson.QQ.Simple

14import Data.HashMap.Strict (HashMap)

15−import qualified Data.Set as Set

15+import qualified Data.HashSet.InsOrd as InsOrdHS

16import Data.Text (Text)

18import Data.Swagger

@@ -43,6 +43,7 @@ spec = do

43 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

44 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

45 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

46 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

47 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

47 describe "Swagger Object" $ do

48 describe "Swagger Object" $ do

48 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

49 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

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

127

128

128operationExample :: Operation

129operationExample :: Operation

129operationExample = mempty

130operationExample = mempty

130− & tags .~ Set.fromList ["pet"]

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

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

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

132 & description ?~ ""

133 & description ?~ ""

133 & operationId ?~ "updatePetWithForm"

134 & operationId ?~ "updatePetWithForm"

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

158 stringSchema :: ParamLocation -> ParamOtherSchema

159 stringSchema :: ParamLocation -> ParamOtherSchema

159 stringSchema loc = mempty

160 stringSchema loc = mempty

160 & in_ .~ loc

161 & in_ .~ loc

161− & type_ .~ SwaggerString

162+ & type_ ?~ SwaggerString

162

163

163operationExampleJSON :: Value

164operationExampleJSON :: Value

164operationExampleJSON = [aesonQQ|

165operationExampleJSON = [aesonQQ|

@@ -224,7 +225,7 @@ operationExampleJSON = [aesonQQ|

224

225

225schemaPrimitiveExample :: Schema

226schemaPrimitiveExample :: Schema

226schemaPrimitiveExample = mempty

227schemaPrimitiveExample = mempty

227− & type_ .~ SwaggerString

228+ & type_ ?~ SwaggerString

228 & format ?~ "email"

229 & format ?~ "email"

229

230

230schemaPrimitiveExampleJSON :: Value

231schemaPrimitiveExampleJSON :: Value

@@ -237,14 +238,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

237

238

238schemaSimpleModelExample :: Schema

239schemaSimpleModelExample :: Schema

239schemaSimpleModelExample = mempty

240schemaSimpleModelExample = mempty

240− & type_ .~ SwaggerObject

241+ & type_ ?~ SwaggerObject

241 & required .~ [ "name" ]

242 & required .~ [ "name" ]

242 & properties .~

243 & properties .~

243− [ ("name", Inline (mempty & type_ .~ SwaggerString))

244+ [ ("name", Inline (mempty & type_ ?~ SwaggerString))

244 , ("address", Ref (Reference "Address"))

245 , ("address", Ref (Reference "Address"))

245 , ("age", Inline $ mempty

246 , ("age", Inline $ mempty

246 & minimum_ ?~ 0

247 & minimum_ ?~ 0

247− & type_ .~ SwaggerInteger

248+ & type_ ?~ SwaggerInteger

248 & format ?~ "int32" ) ]

249 & format ?~ "int32" ) ]

249

250

250schemaSimpleModelExampleJSON :: Value

251schemaSimpleModelExampleJSON :: Value

@@ -272,8 +273,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

272

273

273schemaModelDictExample :: Schema

274schemaModelDictExample :: Schema

274schemaModelDictExample = mempty

275schemaModelDictExample = mempty

275− & type_ .~ SwaggerObject

276+ & type_ ?~ SwaggerObject

276− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ .~ SwaggerString))

277+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

277

278

278schemaModelDictExampleJSON :: Value

279schemaModelDictExampleJSON :: Value

279schemaModelDictExampleJSON = [aesonQQ|

280schemaModelDictExampleJSON = [aesonQQ|

@@ -287,7 +288,7 @@ schemaModelDictExampleJSON = [aesonQQ|

287

288

288schemaAdditionalExample :: Schema

289schemaAdditionalExample :: Schema

289schemaAdditionalExample = mempty

290schemaAdditionalExample = mempty

290− & type_ .~ SwaggerObject

291+ & type_ ?~ SwaggerObject

291 & additionalProperties ?~ AdditionalPropertiesAllowed True

292 & additionalProperties ?~ AdditionalPropertiesAllowed True

292

293

293schemaAdditionalExampleJSON :: Value

294schemaAdditionalExampleJSON :: Value

@@ -300,13 +301,13 @@ schemaAdditionalExampleJSON = [aesonQQ|

300

301

301schemaWithExampleExample :: Schema

302schemaWithExampleExample :: Schema

302schemaWithExampleExample = mempty

303schemaWithExampleExample = mempty

303− & type_ .~ SwaggerObject

304+ & type_ ?~ SwaggerObject

304 & properties .~

305 & properties .~

305 [ ("id", Inline $ mempty

306 [ ("id", Inline $ mempty

306− & type_ .~ SwaggerInteger

307+ & type_ ?~ SwaggerInteger

307 & format ?~ "int64" )

308 & format ?~ "int64" )

308 , ("name", Inline $ mempty

309 , ("name", Inline $ mempty

309− & type_ .~ SwaggerString) ]

310+ & type_ ?~ SwaggerString) ]

310 & required .~ [ "name" ]

311 & required .~ [ "name" ]

311 & example ?~ [aesonQQ|

312 & example ?~ [aesonQQ|

312 {

313 {

@@ -345,19 +346,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

345definitionsExample :: HashMap Text Schema

346definitionsExample :: HashMap Text Schema

346definitionsExample =

347definitionsExample =

347 [ ("Category", mempty

348 [ ("Category", mempty

348− & type_ .~ SwaggerObject

349+ & type_ ?~ SwaggerObject

349 & properties .~

350 & properties .~

350 [ ("id", Inline $ mempty

351 [ ("id", Inline $ mempty

351− & type_ .~ SwaggerInteger

352+ & type_ ?~ SwaggerInteger

352 & format ?~ "int64")

353 & format ?~ "int64")

353− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

354+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

354 , ("Tag", mempty

355 , ("Tag", mempty

355− & type_ .~ SwaggerObject

356+ & type_ ?~ SwaggerObject

356 & properties .~

357 & properties .~

357 [ ("id", Inline $ mempty

358 [ ("id", Inline $ mempty

358− & type_ .~ SwaggerInteger

359+ & type_ ?~ SwaggerInteger

359 & format ?~ "int64")

360 & format ?~ "int64")

360− , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

361+ , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

361

362

362definitionsExampleJSON :: Value

363definitionsExampleJSON :: Value

363definitionsExampleJSON = [aesonQQ|

364definitionsExampleJSON = [aesonQQ|

@@ -401,7 +402,7 @@ paramsDefinitionExample =

401 & required ?~ True

402 & required ?~ True

402 & schema .~ ParamOther (mempty

403 & schema .~ ParamOther (mempty

403 & in_ .~ ParamQuery

404 & in_ .~ ParamQuery

404− & type_ .~ SwaggerInteger

405+ & type_ ?~ SwaggerInteger

405 & format ?~ "int32" ))

406 & format ?~ "int32" ))

406 , ("limitParam", mempty

407 , ("limitParam", mempty

407 & name .~ "limit"

408 & name .~ "limit"

@@ -409,7 +410,7 @@ paramsDefinitionExample =

409 & required ?~ True

410 & required ?~ True

410 & schema .~ ParamOther (mempty

411 & schema .~ ParamOther (mempty

411 & in_ .~ ParamQuery

412 & in_ .~ ParamQuery

412− & type_ .~ SwaggerInteger

413+ & type_ ?~ SwaggerInteger

413 & format ?~ "int32" )) ]

414 & format ?~ "int32" )) ]

414

415

415paramsDefinitionExampleJSON :: Value

416paramsDefinitionExampleJSON :: Value

@@ -459,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

459-- Responses Definition object

460-- Responses Definition object

460-- =======================================================================

461-- =======================================================================

461

462

462−securityDefinitionsExample :: HashMap Text SecurityScheme

463+securityDefinitionsExample :: SecurityDefinitions

463−securityDefinitionsExample =

464+securityDefinitionsExample = SecurityDefinitions

464 [ ("api_key", SecurityScheme

465 [ ("api_key", SecurityScheme

465 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

466 , _securitySchemeDescription = Nothing })

467 , _securitySchemeDescription = Nothing })

@@ -492,6 +493,46 @@ securityDefinitionsExampleJSON = [aesonQQ|

492}

493}

493|]

494|]

494

495

496+oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions

497+oAuth2SecurityDefinitionsReadExample = SecurityDefinitions

498+ [ ("petstore_auth", SecurityScheme

499+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params

500+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"

501+ , _oauth2Scopes =

502+ [ ("read:pets", "read your pets") ] } )

503+ , _securitySchemeDescription = Nothing })

504+ ]

505+

506+oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions

507+oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions

508+ [ ("petstore_auth", SecurityScheme

509+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params

510+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"

511+ , _oauth2Scopes =

512+ [ ("write:pets", "modify pets in your account") ] } )

513+ , _securitySchemeDescription = Nothing })

514+ ]

515+

516+oAuth2SecurityDefinitionsExample :: SecurityDefinitions

517+oAuth2SecurityDefinitionsExample =

518+ oAuth2SecurityDefinitionsWriteExample <>

519+ oAuth2SecurityDefinitionsReadExample

520+

521+oAuth2SecurityDefinitionsExampleJSON :: Value

522+oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|

523+{

524+ "petstore_auth": {

525+ "type": "oauth2",

526+ "authorizationUrl": "http://swagger.io/api/oauth/dialog",

527+ "flow": "implicit",

528+ "scopes": {

529+ "write:pets": "modify pets in your account",

530+ "read:pets": "read your pets"

531+ }

532+ }

533+}

534+|]

535+

495-- =======================================================================

536-- =======================================================================

496-- Swagger object

537-- Swagger object

497-- =======================================================================

538-- =======================================================================

@@ -510,7 +551,7 @@ swaggerExample = mempty

510 & at 200 ?~ Inline (mempty

551 & at 200 ?~ Inline (mempty

511 & description .~ "OK"

552 & description .~ "OK"

512 & schema ?~ Inline (mempty

553 & schema ?~ Inline (mempty

513− & type_ .~ SwaggerObject

554+ & type_ ?~ SwaggerObject

514 & example ?~ [aesonQQ|

555 & example ?~ [aesonQQ|

515 {

556 {

516 "created": 100,

557 "created": 100,

@@ -519,9 +560,9 @@ swaggerExample = mempty

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

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

520 & properties .~

561 & properties .~

521 [ ("created", Inline $ mempty

562 [ ("created", Inline $ mempty

522− & type_ .~ SwaggerInteger

563+ & type_ ?~ SwaggerInteger

523 & format ?~ "int32")

564 & format ?~ "int32")

524− , ("description", Inline (mempty & type_ .~ SwaggerString))]))

565+ , ("description", Inline (mempty & type_ ?~ SwaggerString))]))

525 & produces ?~ MimeList [ "application/json" ]

566 & produces ?~ MimeList [ "application/json" ]

526 & parameters .~

567 & parameters .~

527 [ Inline $ mempty

568 [ Inline $ mempty

@@ -530,8 +571,8 @@ swaggerExample = mempty

530 & description ?~ "TodoId param"

571 & description ?~ "TodoId param"

531 & schema .~ ParamOther (mempty

572 & schema .~ ParamOther (mempty

532 & in_ .~ ParamPath

573 & in_ .~ ParamPath

533− & type_ .~ SwaggerString ) ]

574+ & type_ ?~ SwaggerString ) ]

534− & tags .~ Set.fromList [ "todo" ] ))

575+ & tags .~ InsOrdHS.fromList [ "todo" ] ))

535

576

536swaggerExampleJSON :: Value

577swaggerExampleJSON :: Value

537swaggerExampleJSON = [aesonQQ|

578swaggerExampleJSON = [aesonQQ|

@@ -1632,14 +1673,14 @@ petstoreExampleJSON = [aesonQQ|

1632

1673

1633compositionSchemaExample :: Schema

1674compositionSchemaExample :: Schema

1634compositionSchemaExample = mempty

1675compositionSchemaExample = mempty

1635− & type_ .~ SwaggerObject

1676+ & type_ ?~ SwaggerObject

1636 & Data.Swagger.allOf ?~ [

1677 & Data.Swagger.allOf ?~ [

1637 Ref (Reference "Other")

1678 Ref (Reference "Other")

1638 , Inline (mempty

1679 , Inline (mempty

1639− & type_ .~ SwaggerObject

1680+ & type_ ?~ SwaggerObject

1640 & properties .~

1681 & properties .~

1641 [ ("greet", Inline $ mempty

1682 [ ("greet", Inline $ mempty

1642− & type_ .~ SwaggerString) ])

1683+ & type_ ?~ SwaggerString) ])

1643 ]

1684 ]

1644

1685

1645compositionSchemaExampleJSON :: Value

1686compositionSchemaExampleJSON :: Value