master..022e345 · typeable/swagger2

git.iko.soy/typeable/swagger2

26 files changed+374−1647

unifiedsplit

.ghci−1 .travis.yml+87−128 CHANGELOG.md−40 aeson-0.11.cabal.config+1 cabal.project−2 examples/hackage.hs+1−1 src/Data/Swagger.hs+4−9 src/Data/Swagger/Internal.hs+10−85 src/Data/Swagger/Internal/AesonUtils.hs+2−16 src/Data/Swagger/Internal/ParamSchema.hs+26−38 src/Data/Swagger/Internal/Schema.hs+70−73 src/Data/Swagger/Internal/Schema/Validation.hs+49−207 src/Data/Swagger/Lens.hs+4−10 src/Data/Swagger/Operation.hs+4−5 src/Data/Swagger/Optics.hs−597 src/Data/Swagger/Schema/Generator.hs−114 src/Data/Swagger/Schema/Validation.hs−2 stack.yaml+3−6 swagger2.cabal+25−30 test/Data/Aeson/QQ/Simple.hs+45 test/Data/Swagger/CommonTestTypes.hs+4−31 test/Data/Swagger/ParamSchemaSpec.hs+1−6 test/Data/Swagger/Schema/GeneratorSpec.hs−168 test/Data/Swagger/Schema/ValidationSpec.hs+1−1 test/Data/Swagger/SchemaSpec.hs+6−5 test/Data/SwaggerSpec.hs+31−72

.ghci−1

@@ -1,2 +1 @@

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

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

.travis.yml+87−128

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

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

22#

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

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'

44#

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

66#

7−# version: 0.5.20191020

8−#

97language: c

10−dist: xenial

8+sudo: false

1110git:

12− # whether to recursively clone submodules

13− submodules: false

11+ submodules: false # whether to recursively clone submodules

12+

1413branches:

1514 only:

1615 - master

16+

1717cache:

1818 directories:

1919 - $HOME/.cabal/packages

2020 - $HOME/.cabal/store

21+

2122before_cache:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

30+

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

32+

3033matrix:

3134 include:

32− - compiler: ghc-8.8.1

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

34− - compiler: ghc-8.6.5

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

36− - compiler: ghc-8.4.4

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

38− - compiler: ghc-8.2.2

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

40− - compiler: ghc-8.0.2

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

35+ - compiler: "ghc-8.6.1"

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

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

38+ - compiler: "ghc-8.4.4"

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]}}

41+ - compiler: "ghc-8.2.2"

42+ env: HADDOCK=false

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

44+ - compiler: "ghc-8.0.2"

45+ env: HADDOCK=false

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

47+ - compiler: "ghc-7.10.3"

48+ env: HADDOCK=false

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+

4254before_install:

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

44− - WITHCOMPILER="-w $HC"

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

46− - HCPKG="$HC-pkg"

55+ - HC=${CC}

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

4757 - unset CC

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

49− - CABALHOME=$HOME/.cabal

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

51− - TOP=$(pwd)

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

58+ - ROOTDIR=$(pwd)

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

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

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

5362 - echo $HCNUMVER

54− - CABAL="$CABAL -vnormal+nowrap+markoutput"

55− - set -o pipefail

56− - |

57− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk

58− echo 'BEGIN { state = "output"; }' >> .colorful.awk

59− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk

60− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk

61− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk

62− echo ' if (state == "cabal") {' >> .colorful.awk

63− echo ' print blue($0)' >> .colorful.awk

64− echo ' } else {' >> .colorful.awk

65− echo ' print $0' >> .colorful.awk

66− echo ' }' >> .colorful.awk

67− echo '}' >> .colorful.awk

68− - cat .colorful.awk

69− - |

70− color_cabal_output () {

71− awk -f $TOP/.colorful.awk

72− }

73− - echo text | color_cabal_output

63+

7464install:

75− - ${CABAL} --version

65+ - cabal --version

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

77− - TEST=--enable-tests

78− - BENCH=--enable-benchmarks

79− - HEADHACKAGE=false

80− - rm -f $CABALHOME/config

81− - |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

105− - |

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

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

108− - cat $CABALHOME/config

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

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

111− # Generate cabal.project

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

113− - touch cabal.project

114− - |

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

116− - |

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

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

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

69+ - HADDOCK=${HADDOCK-true}

70+ - UNCONSTRAINED=${UNCONSTRAINED-true}

71+ - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}

72+ - GHCHEAD=${GHCHEAD-false}

73+ - travis_retry cabal update -v

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

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

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

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

78+ - touch cabal.project.local

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"

11880 - cat cabal.project || true

11981 - cat cabal.project.local || true

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

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

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

123− - rm cabal.project.freeze

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

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

126−script:

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

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

84+ fi

85+ - rm -f cabal.project.freeze

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

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

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

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

128− # Packaging...

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

130− # Unpacking...

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.

93+script:

94+ # test that source-distributions can be generated

95+ - cabal new-sdist all

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

13297 - cd ${DISTDIR} || false

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

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

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

136− # Generate cabal.project

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

138− - touch cabal.project

139− - |

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

141− - |

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

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

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

100+ - touch cabal.project.local

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"

143102 - cat cabal.project || true

144103 - cat cabal.project.local || true

145− # Building...

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

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

148− # Building with tests and benchmarks...

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

106+

149107 # build & run tests, build benchmarks

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

151− # Testing...

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

153− # cabal check...

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

155− # haddock...

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

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

158− - rm -f cabal.project.local

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

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

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

110+

111+ # cabal check

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

113+

114+ # haddock

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

116+

117+ # Build 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

160119

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

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"]

162121# EOF

CHANGELOG.md−40

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

1−2.5

2−---

3−

4−Highlights:

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

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

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

8−

9−Fixes and minor changes:

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

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

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

13−

14−2.4

15−---

16−

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

18−- Tags aren't sorted

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

20−- Schema type is optional

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

22−- Take concrete 'Proxy' as argument

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

24−- GHC-8.8 preparations

25−

26−2.3.1.1

27−-------

28−

29−- Allow `network-3.0`

30−

31−2.3.1

32−-----

33−

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

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

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

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

38−- Make nullary schemas valid

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

40−

4112.3.0.1

422-------

433

aeson-0.11.cabal.confignew file+1

@@ -0,0 +1 @@

1+constraints: aeson ==0.11.*

cabal.projectdeleted−2

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

1−packages: .

2−tests: true

examples/hackage.hs+1−1

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

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

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

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

30− & type_ ?~ SwaggerObject

30+ & type_ .~ SwaggerObject

3131 & properties .~

3232 [ ("summaryUsername", usernameSchema )

3333 , ("summaryUserid" , useridSchema )

src/Data/Swagger.hs+4−9

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

3131

3232 -- * Re-exports

3333 module Data.Swagger.Lens,

34− module Data.Swagger.Optics,

3534 module Data.Swagger.Operation,

3635 module Data.Swagger.ParamSchema,

3736 module Data.Swagger.Schema,

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

8988 SecurityScheme(..),

9089 SecuritySchemeType(..),

9190 SecurityRequirement(..),

92− SecurityDefinitions(..),

9391

9492 -- *** API key

9593 ApiKeyParams(..),

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

114112) where

115113

116114import Data.Swagger.Lens

117−import Data.Swagger.Optics ()

118115import Data.Swagger.Operation

119116import Data.Swagger.ParamSchema

120117import Data.Swagger.Schema

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

178175

179176-- $lens

180177--

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

182−--

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

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

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

186181--

187182-- >>> :{

188183-- encode $ (mempty :: Swagger)

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

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

190185-- & paths .~

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

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

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

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

210205-- >>> :{

211206-- encode $ (mempty :: Schema)

212−-- & type_ ?~ SwaggerBoolean

207+-- & type_ .~ SwaggerBoolean

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

214209-- :}

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

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

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

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

220215--

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

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

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

223218--

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

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

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

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

282277--

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

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

284279-- schema for basic enums like

285280--

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

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

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

2929import Data.Aeson

3030import qualified Data.Aeson.Types as JSON

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

32−import Data.Hashable (Hashable)

3332import qualified Data.HashMap.Strict as HashMap

34−import Data.HashSet.InsOrd (InsOrdHashSet)

3533import Data.Map (Map)

3634import qualified Data.Map as Map

3735import Data.Monoid (Monoid (..))

3836import Data.Semigroup.Compat (Semigroup (..))

3937import Data.Scientific (Scientific)

38+import Data.Set (Set)

4039import Data.String (IsString(..))

4140import Data.Text (Text)

4241import qualified Data.Text as Text

4342import GHC.Generics (Generic)

44−import Network.Socket (HostName, PortNumber)

43+import Network (HostName, PortNumber)

4544import Network.HTTP.Media (MediaType)

4645import Text.Read (readMaybe)

4746

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

6665#define DEFINE_TOENCODING

6766#endif

6867

69−-- $setup

70−-- >>> :seti -XDataKinds

71−-- >>> import Data.Aeson

72−

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

7469type Definitions = InsOrdHashMap Text

7570

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

117112 , _swaggerResponses :: Definitions Response

118113

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

120− , _swaggerSecurityDefinitions :: SecurityDefinitions

115+ , _swaggerSecurityDefinitions :: Definitions SecurityScheme

121116

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

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

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

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

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

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

133− , _swaggerTags :: InsOrdHashSet Tag

128+ , _swaggerTags :: Set Tag

134129

135130 -- | Additional external documentation.

136131 , _swaggerExternalDocs :: Maybe ExternalDocs

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

252247data Operation = Operation

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

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

255− _operationTags :: InsOrdHashSet TagName

250+ _operationTags :: Set TagName

256251

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

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

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

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

595590 _paramSchemaDefault :: Maybe Value

596591

597− , _paramSchemaType :: Maybe (SwaggerType t)

592+ , _paramSchemaType :: SwaggerType t

598593 , _paramSchemaFormat :: Maybe Format

599594 , _paramSchemaItems :: Maybe (SwaggerItems t)

600595 , _paramSchemaMaximum :: Maybe Scientific

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

611606 , _paramSchemaMultipleOf :: Maybe Scientific

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

613608

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

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

615610

616611data Xml = Xml

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

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

755750 , _securitySchemeDescription :: Maybe Text

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

757752

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−

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

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

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

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

795774 , _tagExternalDocs :: Maybe ExternalDocs

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

797776

798−instance Hashable Tag

799−

800777instance IsString Tag where

801778 fromString s = Tag (fromString s) Nothing Nothing

802779

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

810787 , _externalDocsUrl :: URL

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

812789

813−instance Hashable ExternalDocs

814−

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

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

817792newtype Reference = Reference { getReference :: Text }

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

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

826801 fromString = Inline . fromString

827802

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

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

829804

830805data AdditionalProperties

831806 = AdditionalPropertiesAllowed Bool

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

920895 mempty = genericMempty

921896 mappend = (<>)

922897

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−

934898-- =======================================================================

935899-- SwaggerMonoid helper instances

936900-- =======================================================================

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

945909instance SwaggerMonoid Response

946910instance SwaggerMonoid ExternalDocs

947911instance SwaggerMonoid Operation

948−instance SwaggerMonoid SecurityDefinitions

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

950912

951913instance SwaggerMonoid MimeList

952914deriving instance SwaggerMonoid URL

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

10881050 toJSON = sopSwaggerGenericToJSON

10891051 DEFINE_TOENCODING

10901052

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

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

10981054 toJSON (SwaggerItemsPrimitive fmt schema) = object

10991055 [ "collectionFormat" .= fmt

11001056 , "items" .= schema ]

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

1102− toJSON (SwaggerItemsArray []) = object

1103− [ "items" .= object []

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

1105− , "example" .= Array mempty

1106− ]

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

11081059

11091060instance ToJSON Host where

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

11461097instance ToJSON Example where

11471098 toJSON = toJSON . Map.mapKeys show . getExample

11481099

1149−instance ToJSON SecurityDefinitions where

1150− toJSON (SecurityDefinitions sd) = toJSON sd

1151−

11521100instance ToJSON Reference where

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

11541102

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

12231171 parseJSON = sopSwaggerGenericParseJSON

12241172

12251173instance FromJSON Schema where

1226− parseJSON = fmap nullaryCleanup . sopSwaggerGenericParseJSON

1227− where nullaryCleanup :: Schema -> Schema

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

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

1230− then s { _schemaExample = Nothing

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

1232− else s

1174+ parseJSON = sopSwaggerGenericParseJSON

12331175

12341176instance FromJSON Header where

12351177 parseJSON = sopSwaggerGenericParseJSON

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

12441186 <$> o .:? "collectionFormat"

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

12461188

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

12581189instance FromJSON (SwaggerItems 'SwaggerKindSchema) where

1259− parseJSON js@(Object obj)

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

1261− | otherwise = SwaggerItemsObject <$> parseJSON js

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

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

12631192 parseJSON _ = empty

12641193

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

13101239instance FromJSON PathItem where

13111240 parseJSON = sopSwaggerGenericParseJSON

13121241

1313−instance FromJSON SecurityDefinitions where

1314− parseJSON js = SecurityDefinitions <$> parseJSON js

1315−

13161242instance FromJSON Reference where

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

13181244 parseJSON _ = empty

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

14241350instance AesonDefaultValue MimeList where defaultValue = Just mempty

14251351instance AesonDefaultValue Info

14261352instance AesonDefaultValue ParamLocation

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

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

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

4444import qualified Data.HashMap.Strict as HM

4545import qualified Data.Set as Set

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

47−import qualified Data.HashSet.InsOrd as InsOrdHS

4847

4948#if MIN_VERSION_aeson(0,10,0)

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

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

6867makeLenses ''SwaggerAesonOptions

6968

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

71− swaggerAesonOptions :: Proxy a -> SwaggerAesonOptions

70+ swaggerAesonOptions :: proxy a -> SwaggerAesonOptions

7271

7372 -- So far we use only default definitions

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

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

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

7675

7776-------------------------------------------------------------------------------

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

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

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

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

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

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

9189

9290-------------------------------------------------------------------------------

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

146144 -> DatatypeInfo '[xs]

147145 -> POP Maybe '[xs]

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

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

153−#endif

154148 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

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

156150

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

226220 -> DatatypeInfo '[xs]

227221 -> POP Maybe '[xs]

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

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

233−#endif

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

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

236226

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

302292 -> DatatypeInfo '[xs]

303293 -> POP Maybe '[xs]

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

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

309−#endif

310296 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

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

312298

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

@@ -43,7 +43,6 @@ import Data.Version (Version)

4343import Numeric.Natural.Compat (Natural)

4444import Data.Word

4545import Data.UUID.Types (UUID)

46−import Web.Cookie (SetCookie)

4746

4847import Data.Swagger.Internal

4948import Data.Swagger.Lens

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

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

6059binaryParamSchema :: ParamSchema t

6160binaryParamSchema = mempty

62− & type_ ?~ SwaggerString

61+ & type_ .~ SwaggerString

6362 & format ?~ "binary"

6463

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

6665byteParamSchema :: ParamSchema t

6766byteParamSchema = mempty

68− & type_ ?~ SwaggerString

67+ & type_ .~ SwaggerString

6968 & format ?~ "byte"

7069

7170-- | Default schema for password string.

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

7372passwordParamSchema :: ParamSchema t

7473passwordParamSchema = mempty

75− & type_ ?~ SwaggerString

74+ & type_ .~ SwaggerString

7675 & format ?~ "password"

7776

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

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

8887--

8988-- instance ToParamSchema Direction where

9089-- toParamSchema _ = mempty

91−-- & type_ ?~ SwaggerString

90+-- & type_ .~ SwaggerString

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

9392-- @

9493--

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

115114 --

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

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

118− toParamSchema :: Proxy a -> ParamSchema t

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

117+ toParamSchema :: proxy a -> ParamSchema t

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

120119 toParamSchema = genericToParamSchema defaultSchemaOptions

121120

122121instance OVERLAPPING_ ToParamSchema String where

123− toParamSchema _ = mempty & type_ ?~ SwaggerString

122+ toParamSchema _ = mempty & type_ .~ SwaggerString

124123

125124instance ToParamSchema Bool where

126− toParamSchema _ = mempty & type_ ?~ SwaggerBoolean

125+ toParamSchema _ = mempty & type_ .~ SwaggerBoolean

127126

128127instance ToParamSchema Integer where

129− toParamSchema _ = mempty & type_ ?~ SwaggerInteger

128+ toParamSchema _ = mempty & type_ .~ SwaggerInteger

130129

131130instance ToParamSchema Natural where

132131 toParamSchema _ = mempty

133− & type_ ?~ SwaggerInteger

132+ & type_ .~ SwaggerInteger

134133 & minimum_ ?~ 0

135134 & exclusiveMinimum ?~ False

136135

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

154153--

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

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

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

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

158157toParamSchemaBoundedIntegral _ = mempty

159− & type_ ?~ SwaggerInteger

158+ & type_ .~ SwaggerInteger

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

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

162161

163162instance ToParamSchema Char where

164163 toParamSchema _ = mempty

165− & type_ ?~ SwaggerString

164+ & type_ .~ SwaggerString

166165 & maxLength ?~ 1

167166 & minLength ?~ 1

168167

169168instance ToParamSchema Scientific where

170− toParamSchema _ = mempty & type_ ?~ SwaggerNumber

169+ toParamSchema _ = mempty & type_ .~ SwaggerNumber

171170

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

173172 toParamSchema _ = mempty

174− & type_ ?~ SwaggerNumber

173+ & type_ .~ SwaggerNumber

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

176175

177176instance ToParamSchema Double where

178177 toParamSchema _ = mempty

179− & type_ ?~ SwaggerNumber

178+ & type_ .~ SwaggerNumber

180179 & format ?~ "double"

181180

182181instance ToParamSchema Float where

183182 toParamSchema _ = mempty

184− & type_ ?~ SwaggerNumber

183+ & type_ .~ SwaggerNumber

185184 & format ?~ "float"

186185

187186timeParamSchema :: String -> ParamSchema t

188187timeParamSchema fmt = mempty

189− & type_ ?~ SwaggerString

188+ & type_ .~ SwaggerString

190189 & format ?~ T.pack fmt

191190

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

193192instance ToParamSchema Day where

194193 toParamSchema _ = timeParamSchema "date"

195194

196−-- |

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

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

199−instance ToParamSchema TimeOfDay where

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

201−

202195-- |

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

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

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

228221

229222instance ToParamSchema Version where

230223 toParamSchema _ = mempty

231− & type_ ?~ SwaggerString

224+ & type_ .~ SwaggerString

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

233226

234−instance ToParamSchema SetCookie where

235− toParamSchema _ = mempty

236− & type_ ?~ SwaggerString

237−

238−

239227#if __GLASGOW_HASKELL__ < 800

240228#else

241229type family ToParamSchemaByteStringError bs where

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

260248

261249instance ToParamSchema a => ToParamSchema [a] where

262250 toParamSchema _ = mempty

263− & type_ ?~ SwaggerArray

251+ & type_ .~ SwaggerArray

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

265253

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

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

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

281269instance ToParamSchema () where

282270 toParamSchema _ = mempty

283− & type_ ?~ SwaggerString

271+ & type_ .~ SwaggerString

284272 & enum_ ?~ ["_"]

285273

286274instance ToParamSchema UUID where

287275 toParamSchema _ = mempty

288− & type_ ?~ SwaggerString

276+ & type_ .~ SwaggerString

289277 & format ?~ "uuid"

290278

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

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

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

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

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

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

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

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

299287

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

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

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

302290

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

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

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

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

317305

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

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

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

320308

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

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

323311

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

325313 genumParamSchema opts _ s = s

326− & type_ ?~ SwaggerString

314+ & type_ .~ SwaggerString

327315 & enum_ %~ addEnumValue tag

328316 where

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

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

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

111111-- declareNamedSchema _ = do

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

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

114−-- & type_ ?~ SwaggerObject

114+-- & type_ .~ SwaggerObject

115115-- & properties .~

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

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

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

142142 -- together with all used definitions.

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

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

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

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

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

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

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

148148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

149149

150−instance ToSchema TimeOfDay where

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

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

153−

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

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

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

156152declareSchema = fmap _namedSchemaSchema . declareNamedSchema

157153

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

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

166162-- Just "Day"

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

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

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

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

170166toNamedSchema = undeclare . declareNamedSchema

171167

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

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

176172--

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

178174-- Just "UTCTime"

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

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

180176schemaName = _namedSchemaName . toNamedSchema

181177

182178-- | Convert a type into a schema.

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

186182--

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

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

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

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

190186toSchema = _namedSchemaSchema . toNamedSchema

191187

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

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

197193--

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

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

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

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

201197toSchemaRef = undeclare . declareSchemaRef

202198

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

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

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

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

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

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

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

211207declareSchemaRef proxy = do

212208 case toNamedSchema proxy of

213209 NamedSchema (Just name) schema -> do

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

269265--

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

271267-- when inlining recursive schemas.

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

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

273269toInlinedSchema proxy = inlineAllSchemas defs schema

274270 where

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

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

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

299295binarySchema :: Schema

300296binarySchema = mempty

301− & type_ ?~ SwaggerString

297+ & type_ .~ SwaggerString

302298 & format ?~ "binary"

303299

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

305301byteSchema :: Schema

306302byteSchema = mempty

307− & type_ ?~ SwaggerString

303+ & type_ .~ SwaggerString

308304 & format ?~ "byte"

309305

310306-- | Default schema for password string.

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

312308passwordSchema :: Schema

313309passwordSchema = mempty

314− & type_ ?~ SwaggerString

310+ & type_ .~ SwaggerString

315311 & format ?~ "password"

316312

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

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

337333 sketch js@(Bool _) = go js

338334 sketch js = go js & example ?~ js

339335

340− go Null = mempty & type_ ?~ SwaggerNull

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

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

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

336+ go Null = mempty & type_ .~ SwaggerNull

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

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

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

344340 go (Array xs) = mempty

345− & type_ ?~ SwaggerArray

341+ & type_ .~ SwaggerArray

346342 & items ?~ case ischema of

347343 Just s -> SwaggerItemsObject (Inline s)

348344 _ -> SwaggerItemsArray (map Inline ys)

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

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

355351 _ -> Nothing

356352 go (Object o) = mempty

357− & type_ ?~ SwaggerObject

353+ & type_ .~ SwaggerObject

358354 & required .~ HashMap.keys o

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

360356

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

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

378374sketchStrictSchema = go . toJSON

379375 where

380− go Null = mempty & type_ ?~ SwaggerNull

376+ go Null = mempty & type_ .~ SwaggerNull

381377 go js@(Bool _) = mempty

382− & type_ ?~ SwaggerBoolean

378+ & type_ .~ SwaggerBoolean

383379 & enum_ ?~ [js]

384380 go js@(String s) = mempty

385− & type_ ?~ SwaggerString

381+ & type_ .~ SwaggerString

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

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

388384 & pattern ?~ s

389385 & enum_ ?~ [js]

390386 go js@(Number n) = mempty

391− & type_ ?~ SwaggerNumber

387+ & type_ .~ SwaggerNumber

392388 & maximum_ ?~ n

393389 & minimum_ ?~ n

394390 & multipleOf ?~ n

395391 & enum_ ?~ [js]

396392 go js@(Array xs) = mempty

397− & type_ ?~ SwaggerArray

393+ & type_ .~ SwaggerArray

398394 & maxItems ?~ fromIntegral sz

399395 & minItems ?~ fromIntegral sz

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

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

404400 sz = length xs

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

406402 go js@(Object o) = mempty

407− & type_ ?~ SwaggerObject

403+ & type_ .~ SwaggerObject

408404 & required .~ names

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

410406 & maxProperties ?~ fromIntegral (length names)

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

414410 names = HashMap.keys o

415411

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

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

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

418414

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

420416 declareNamedSchema _ = do

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

422418 return $ unnamed $ mempty

423− & type_ ?~ SwaggerArray

419+ & type_ .~ SwaggerArray

424420 & items ?~ SwaggerItemsObject ref

425421

426422instance OVERLAPPING_ ToSchema String where declareNamedSchema = plain . paramSchemaToSchema

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

470466

471467timeSchema :: T.Text -> Schema

472468timeSchema fmt = mempty

473− & type_ ?~ SwaggerString

469+ & type_ .~ SwaggerString

474470 & format ?~ fmt

475471

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

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

532528 declareObjectMapSchema = do

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

534530 return $ unnamed $ mempty

535− & type_ ?~ SwaggerObject

531+ & type_ .~ SwaggerObject

536532 & additionalProperties ?~ AdditionalPropertiesSchema schema

537533

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

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

544540 declareNamedSchema _ = do

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

546542 return $ unnamed $ mempty

547− & type_ ?~ SwaggerObject

543+ & type_ .~ SwaggerObject

548544 & additionalProperties ?~ schema

549545

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

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

558554

559555instance OVERLAPPING_ ToSchema Object where

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

561− & type_ ?~ SwaggerObject

557+ & type_ .~ SwaggerObject

562558 & description ?~ "Arbitrary JSON object."

563559 & additionalProperties ?~ AdditionalPropertiesAllowed True

564560

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

597593--

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

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

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

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

601597toSchemaBoundedIntegral _ = mempty

602− & type_ ?~ SwaggerInteger

598+ & type_ .~ SwaggerInteger

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

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

605601

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

607−genericToNamedSchemaBoundedIntegral :: forall a d f.

603+genericToNamedSchemaBoundedIntegral :: forall a d f proxy.

608604 ( Bounded a, Integral a

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

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

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

611607genericToNamedSchemaBoundedIntegral opts proxy

612608 = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

613609

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

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

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

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

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

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

619− -> Proxy a

615+ -> proxy a

620616 -> Declare (Definitions Schema) NamedSchema

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

622618

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

633629--

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

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

636−declareSchemaBoundedEnumKeyMapping :: forall map key value.

632+declareSchemaBoundedEnumKeyMapping :: forall map key value proxy.

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

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

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

639635declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of

640636 ToJSONKeyText keyToText _ -> objectSchema keyToText

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

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

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

646642 mkPair k = (keyToText k, valueRef)

647643 return $ mempty

648− & type_ ?~ SwaggerObject

644+ & type_ .~ SwaggerObject

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

650646

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

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

661657--

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

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

664−toSchemaBoundedEnumKeyMapping :: forall map key value.

660+toSchemaBoundedEnumKeyMapping :: forall map key value proxy.

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

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

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

667663toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

668664

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

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

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

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

672668genericDeclareSchema = genericDeclareSchemaUnrestricted

673669

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

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

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

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

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

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

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

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

680676genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

681677

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

683679--

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

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

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

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

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

688684

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

690686--

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

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

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

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

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

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

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

696692

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

698−genericNameSchema :: forall a d f.

694+genericNameSchema :: forall a d f proxy.

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

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

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

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

702698

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

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

704700gdatatypeSchemaName opts _ = case orig of

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

706702 _ -> Nothing

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

709705 name = datatypeNameModifier opts orig

710706

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

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

713− SchemaOptions -> Proxy a -> NamedSchema

708+paramSchemaToNamedSchema :: forall a d f proxy.

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

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

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

715712

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

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

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

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

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

719716

720717nullarySchema :: Schema

721718nullarySchema = mempty

722− & type_ ?~ SwaggerArray

719+ & type_ .~ SwaggerArray

723720 & items ?~ SwaggerItemsArray []

724721

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

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

726723gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

727724

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

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

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

730727

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

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

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

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

761758

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

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

763760gdeclareSchemaRef opts proxy = do

764761 case gtoNamedSchema opts proxy of

765762 NamedSchema (Just name) schema -> do

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

790787 return $

791788 if T.null fname

792789 then schema

793− & type_ ?~ SwaggerArray

790+ & type_ .~ SwaggerArray

794791 & items %~ appendItem ref

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

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

797794 else schema

798− & type_ ?~ SwaggerObject

795+ & type_ .~ SwaggerObject

799796 & properties . at fname ?~ ref

800797 & if isRequiredField

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

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

823820 where

824821 gdeclareNamedSchema = gdeclareNamedSumSchema

825822

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

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

827824gdeclareNamedSumSchema opts proxy s

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

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

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

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

833830

834831 toStringTag schema = mempty

835− & type_ ?~ SwaggerString

832+ & type_ .~ SwaggerString

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

837834

838835type AllNullary = All

839836

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

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

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

842839

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

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

845842

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

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

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

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

848845gsumConToSchemaWith ref opts _ schema = schema

849− & type_ ?~ SwaggerObject

846+ & type_ .~ SwaggerObject

850847 & properties . at tag ?~ ref

851848 & maxProperties ?~ 1

852849 & minProperties ?~ 1

853850 where

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

855852

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

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

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

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

858855gsumConToSchema opts proxy schema = do

859856 ref <- gdeclareSchemaRef opts proxy

860857 return $ gsumConToSchemaWith ref opts proxy schema

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

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

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE GADTs #-}

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE GADTs #-}

75{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE LambdaCase #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE PackageImports #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TemplateHaskell #-}

14−{-# LANGUAGE UndecidableInstances #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE PackageImports #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TemplateHaskell #-}

12+{-# LANGUAGE UndecidableInstances #-}

1513-- |

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

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

2220-- Validate JSON values with Swagger Schema.

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

2422

25−import Prelude ()

26−import Prelude.Compat

23+import Control.Applicative

24+import Control.Lens

25+import Control.Monad (when)

2726

28−import Control.Applicative

29−import Control.Lens

30−import Control.Monad (when)

31−

32−import Data.Aeson hiding (Result)

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

34−import Data.Foldable (for_, sequenceA_,

35− traverse_)

36−import Data.HashMap.Strict (HashMap)

37−import qualified Data.HashMap.Strict as HashMap

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

27+import Data.Aeson hiding (Result)

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

29+import Data.HashMap.Strict (HashMap)

30+import qualified Data.HashMap.Strict as HashMap

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

40−import Data.Proxy

41−import Data.Scientific (Scientific, isInteger)

42−import Data.Text (Text)

43−import qualified Data.Text as Text

44−import qualified Data.Text.Lazy as TL

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

46−import Data.Vector (Vector)

47−import qualified Data.Vector as Vector

48−

49−import Data.Swagger.Declare

50−import Data.Swagger.Internal

51−import Data.Swagger.Internal.Schema

52−import Data.Swagger.Lens

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

33+import Data.Monoid

34+import Data.Proxy

35+import Data.Scientific (Scientific, isInteger)

36+import Data.Text (Text)

37+import qualified Data.Text as Text

38+import Data.Vector (Vector)

39+import qualified Data.Vector as Vector

40+

41+import Data.Swagger.Declare

42+import Data.Swagger.Internal

43+import Data.Swagger.Internal.Schema

44+import Data.Swagger.Lens

5345

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

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

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

5850--

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

6052-- See @'validateToJSONWithPatternChecker'@.

61−--

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

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

64−validatePrettyToJSON = renderValidationErrors validateToJSON

65−

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

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

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

6955

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

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

7258--

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

74−-- 'renderValidationErrors'.

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

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

7661validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

7762 where

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

7964

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−

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

15766--

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

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

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

412321

413322 unknownProperty :: Text -> Validation s a

414− unknownProperty pname = invalid $

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

323+ unknownProperty name = invalid $

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

416325

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

418327validateEnum value = do

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

420329 when (value `notElem` xs) $

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

422331

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−

470332validateSchemaType :: Value -> Validation Schema ()

471333validateSchemaType value = withSchema $ \sch ->

472334 case (sch ^. type_, value) of

473− (Just SwaggerNull, Null) -> valid

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

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

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

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

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

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

480− (Nothing, Null) -> valid

481− (Nothing, Bool _) -> valid

482− -- Number by default

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

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

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

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

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

335+ (SwaggerNull, Null) -> valid

336+ (SwaggerBoolean, Bool _) -> valid

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

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

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

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

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

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

488343

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

490345validateParamSchemaType value = withSchema $ \sch ->

491346 case (sch ^. type_, value) of

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

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

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

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

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

497− (Nothing, Bool _) -> valid

498− -- Number by default

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

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

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

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

503−

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

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

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

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

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

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

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

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

347+ (SwaggerBoolean, Bool _) -> valid

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

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

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

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

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

353+

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

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

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

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

9898

99−type instance Index SecurityDefinitions = Text

100−type instance IxValue SecurityDefinitions = SecurityScheme

101−

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

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

104−

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

106100

107101-- HasType instances

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

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

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

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

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

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

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

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

112106

113107-- HasDefault instances

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

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

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

3737import Data.Data.Lens

3838import Data.List.Compat

3939import Data.Maybe (mapMaybe)

40−import Data.Proxy

4140import qualified Data.Set as Set

4241

4342import Data.Swagger.Declare

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

4645import Data.Swagger.Schema

4746

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

49−import qualified Data.HashSet.InsOrd as InsOrdHS

5048

5149-- $setup

5250-- >>> import Data.Aeson

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

112110-- list of tags.

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

114112applyTagsFor ops ts swag = swag

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

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

113+ & ops . tags %~ (<> Set.fromList (map _tagName ts))

114+ & tags %~ (<> Set.fromList ts)

117115

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

119117-- necessary schema definitions.

120118--

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

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

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

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

124122declareResponse proxy = do

125123 s <- declareSchemaRef proxy

126124 return (mempty & schema ?~ s)

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

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

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

193191 combine Nothing = new

192+

src/Data/Swagger/Optics.hsdeleted−597

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE OverloadedLabels #-}

5−{-# LANGUAGE TemplateHaskell #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE UndecidableInstances #-}

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

9−-- |

10−-- Module: Data.Swagger.Optics

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

12−-- Stability: experimental

13−--

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

15−-- library.

16−--

17−-- >>> import Data.Aeson

18−-- >>> import Optics.Core

19−-- >>> :set -XOverloadedLabels

20−--

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

22−--

23−-- >>> :{

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

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

26−-- & #paths .~

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

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

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

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

31−-- :}

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

33−--

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

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

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

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

38−--

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

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

41−-- >>> :{

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

43−-- & #type ?~ SwaggerBoolean

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

45−-- :}

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

47−--

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

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

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

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

52−-- @#paramSchema@:

53−--

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

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

56−--

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

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

59−--

60−-- >>> :{

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

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

63−-- :}

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

65−--

66−module Data.Swagger.Optics () where

67−

68−import Data.Aeson (Value)

69−import Data.Scientific (Scientific)

70−import Data.Swagger.Internal

71−import Data.Text (Text)

72−import Optics.Core

73−import Optics.TH

74−

75−-- Lenses

76−

77−makeFieldLabels ''Swagger

78−makeFieldLabels ''Host

79−makeFieldLabels ''Info

80−makeFieldLabels ''Contact

81−makeFieldLabels ''License

82−makeFieldLabels ''PathItem

83−makeFieldLabels ''Tag

84−makeFieldLabels ''Operation

85−makeFieldLabels ''Param

86−makeFieldLabels ''ParamOtherSchema

87−makeFieldLabels ''Header

88−makeFieldLabels ''Schema

89−makeFieldLabels ''NamedSchema

90−makeFieldLabels ''ParamSchema

91−makeFieldLabels ''Xml

92−makeFieldLabels ''Responses

93−makeFieldLabels ''Response

94−makeFieldLabels ''SecurityScheme

95−makeFieldLabels ''ApiKeyParams

96−makeFieldLabels ''OAuth2Params

97−makeFieldLabels ''ExternalDocs

98−

99−-- Prisms

100−

101−makePrismLabels ''ParamAnySchema

102−makePrismLabels ''SecuritySchemeType

103−makePrismLabels ''Referenced

104−

105−-- SwaggerItems prisms

106−

107−instance

108− ( a ~ [Referenced Schema]

109− , b ~ [Referenced Schema]

110− ) => LabelOptic "_SwaggerItemsArray"

111− A_Review

112− (SwaggerItems 'SwaggerKindSchema)

113− (SwaggerItems 'SwaggerKindSchema)

114− a

115− b where

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

117− {-# INLINE labelOptic #-}

118−

119−instance

120− ( a ~ Referenced Schema

121− , b ~ Referenced Schema

122− ) => LabelOptic "_SwaggerItemsObject"

123− A_Review

124− (SwaggerItems 'SwaggerKindSchema)

125− (SwaggerItems 'SwaggerKindSchema)

126− a

127− b where

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

129− {-# INLINE labelOptic #-}

130−

131−instance

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

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

134− ) => LabelOptic "_SwaggerItemsPrimitive"

135− A_Review

136− (SwaggerItems t)

137− (SwaggerItems t)

138− a

139− b where

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

141− {-# INLINE labelOptic #-}

142−

143−-- =============================================================

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

145−

146−type instance Index Responses = HttpStatusCode

147−type instance Index Operation = HttpStatusCode

148−

149−type instance IxValue Responses = Referenced Response

150−type instance IxValue Operation = Referenced Response

151−

152−instance Ixed Responses where

153− ix n = #responses % ix n

154− {-# INLINE ix #-}

155−instance At Responses where

156− at n = #responses % at n

157− {-# INLINE at #-}

158−

159−instance Ixed Operation where

160− ix n = #responses % ix n

161− {-# INLINE ix #-}

162−instance At Operation where

163− at n = #responses % at n

164− {-# INLINE at #-}

165−

166−-- #paramSchema

167−

168−instance

169− ( a ~ ParamSchema 'SwaggerKindSchema

170− , b ~ ParamSchema 'SwaggerKindSchema

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

172− labelOptic = #schema % #paramSchema

173− {-# INLINE labelOptic #-}

174−

175−-- #type

176−

177−instance

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

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

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

181− labelOptic = #paramSchema % #type

182− {-# INLINE labelOptic #-}

183−

184−instance

185− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

186− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

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

188− labelOptic = #paramSchema % #type

189− {-# INLINE labelOptic #-}

190−

191−instance

192− ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

193− , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

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

195− labelOptic = #paramSchema % #type

196− {-# INLINE labelOptic #-}

197−

198−instance

199− ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

200− , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

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

202− labelOptic = #paramSchema % #type

203− {-# INLINE labelOptic #-}

204−

205−-- #default

206−

207−instance

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

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

210− labelOptic = #paramSchema % #default

211− {-# INLINE labelOptic #-}

212−

213−instance

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

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

216− labelOptic = #paramSchema % #default

217− {-# INLINE labelOptic #-}

218−

219−instance

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

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

222− labelOptic = #paramSchema % #default

223− {-# INLINE labelOptic #-}

224−

225−instance

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

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

228− labelOptic = #paramSchema % #default

229− {-# INLINE labelOptic #-}

230−

231−-- #format

232−

233−instance

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

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

236− labelOptic = #paramSchema % #format

237− {-# INLINE labelOptic #-}

238−

239−instance

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

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

242− labelOptic = #paramSchema % #format

243− {-# INLINE labelOptic #-}

244−

245−instance

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

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

248− labelOptic = #paramSchema % #format

249− {-# INLINE labelOptic #-}

250−

251−instance

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

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

254− labelOptic = #paramSchema % #format

255− {-# INLINE labelOptic #-}

256−

257−-- #items

258−

259−instance

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

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

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

263− labelOptic = #paramSchema % #items

264− {-# INLINE labelOptic #-}

265−

266−instance

267− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

268− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

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

270− labelOptic = #paramSchema % #items

271− {-# INLINE labelOptic #-}

272−

273−instance

274− ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

275− , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

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

277− labelOptic = #paramSchema % #items

278− {-# INLINE labelOptic #-}

279−

280−instance

281− ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

282− , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

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

284− labelOptic = #paramSchema % #items

285− {-# INLINE labelOptic #-}

286−

287−-- #maximum

288−

289−instance

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

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

292− labelOptic = #paramSchema % #maximum

293− {-# INLINE labelOptic #-}

294−

295−instance

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

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

298− labelOptic = #paramSchema % #maximum

299− {-# INLINE labelOptic #-}

300−

301−instance

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

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

304− labelOptic = #paramSchema % #maximum

305− {-# INLINE labelOptic #-}

306−

307−instance

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

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

310− labelOptic = #paramSchema % #maximum

311− {-# INLINE labelOptic #-}

312−

313−-- #exclusiveMaximum

314−

315−instance

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

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

318− labelOptic = #paramSchema % #exclusiveMaximum

319− {-# INLINE labelOptic #-}

320−

321−instance

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

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

324− labelOptic = #paramSchema % #exclusiveMaximum

325− {-# INLINE labelOptic #-}

326−

327−instance

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

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

330− labelOptic = #paramSchema % #exclusiveMaximum

331− {-# INLINE labelOptic #-}

332−

333−instance

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

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

336− labelOptic = #paramSchema % #exclusiveMaximum

337− {-# INLINE labelOptic #-}

338−

339−-- #minimum

340−

341−instance

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

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

344− labelOptic = #paramSchema % #minimum

345− {-# INLINE labelOptic #-}

346−

347−instance

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

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

350− labelOptic = #paramSchema % #minimum

351− {-# INLINE labelOptic #-}

352−

353−instance

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

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

356− labelOptic = #paramSchema % #minimum

357− {-# INLINE labelOptic #-}

358−

359−instance

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

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

362− labelOptic = #paramSchema % #minimum

363− {-# INLINE labelOptic #-}

364−

365−-- #exclusiveMinimum

366−

367−instance

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

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

370− labelOptic = #paramSchema % #exclusiveMinimum

371− {-# INLINE labelOptic #-}

372−

373−instance

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

375− ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where

376− labelOptic = #paramSchema % #exclusiveMinimum

377− {-# INLINE labelOptic #-}

378−

379−instance

380− ( a ~ Maybe Bool, b ~ Maybe Bool

381− ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where

382− labelOptic = #paramSchema % #exclusiveMinimum

383− {-# INLINE labelOptic #-}

384−

385−instance

386− ( a ~ Maybe Bool, b ~ Maybe Bool

387− ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where

388− labelOptic = #paramSchema % #exclusiveMinimum

389− {-# INLINE labelOptic #-}

390−

391−-- #maxLength

392−

393−instance

394− ( a ~ Maybe Integer, b ~ Maybe Integer

395− ) => LabelOptic "maxLength" A_Lens Header Header a b where

396− labelOptic = #paramSchema % #maxLength

397− {-# INLINE labelOptic #-}

398−

399−instance

400− ( a ~ Maybe Integer, b ~ Maybe Integer

401− ) => LabelOptic "maxLength" A_Lens Schema Schema a b where

402− labelOptic = #paramSchema % #maxLength

403− {-# INLINE labelOptic #-}

404−

405−instance

406− ( a ~ Maybe Integer, b ~ Maybe Integer

407− ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where

408− labelOptic = #paramSchema % #maxLength

409− {-# INLINE labelOptic #-}

410−

411−instance

412− ( a ~ Maybe Integer, b ~ Maybe Integer

413− ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

414− labelOptic = #paramSchema % #maxLength

415− {-# INLINE labelOptic #-}

416−

417−-- #minLength

418−

419−instance

420− ( a ~ Maybe Integer, b ~ Maybe Integer

421− ) => LabelOptic "minLength" A_Lens Header Header a b where

422− labelOptic = #paramSchema % #minLength

423− {-# INLINE labelOptic #-}

424−

425−instance

426− ( a ~ Maybe Integer, b ~ Maybe Integer

427− ) => LabelOptic "minLength" A_Lens Schema Schema a b where

428− labelOptic = #paramSchema % #minLength

429− {-# INLINE labelOptic #-}

430−

431−instance

432− ( a ~ Maybe Integer, b ~ Maybe Integer

433− ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where

434− labelOptic = #paramSchema % #minLength

435− {-# INLINE labelOptic #-}

436−

437−instance

438− ( a ~ Maybe Integer, b ~ Maybe Integer

439− ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where

440− labelOptic = #paramSchema % #minLength

441− {-# INLINE labelOptic #-}

442−

443−-- #pattern

444−

445−instance

446− ( a ~ Maybe Text, b ~ Maybe Text

447− ) => LabelOptic "pattern" A_Lens Header Header a b where

448− labelOptic = #paramSchema % #pattern

449− {-# INLINE labelOptic #-}

450−

451−instance

452− ( a ~ Maybe Text, b ~ Maybe Text

453− ) => LabelOptic "pattern" A_Lens Schema Schema a b where

454− labelOptic = #paramSchema % #pattern

455− {-# INLINE labelOptic #-}

456−

457−instance

458− ( a ~ Maybe Text, b ~ Maybe Text

459− ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where

460− labelOptic = #paramSchema % #pattern

461− {-# INLINE labelOptic #-}

462−

463−instance

464− ( a ~ Maybe Text, b ~ Maybe Text

465− ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where

466− labelOptic = #paramSchema % #pattern

467− {-# INLINE labelOptic #-}

468−

469−-- #maxItems

470−

471−instance

472− ( a ~ Maybe Integer, b ~ Maybe Integer

473− ) => LabelOptic "maxItems" A_Lens Header Header a b where

474− labelOptic = #paramSchema % #maxItems

475− {-# INLINE labelOptic #-}

476−

477−instance

478− ( a ~ Maybe Integer, b ~ Maybe Integer

479− ) => LabelOptic "maxItems" A_Lens Schema Schema a b where

480− labelOptic = #paramSchema % #maxItems

481− {-# INLINE labelOptic #-}

482−

483−instance

484− ( a ~ Maybe Integer, b ~ Maybe Integer

485− ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where

486− labelOptic = #paramSchema % #maxItems

487− {-# INLINE labelOptic #-}

488−

489−instance

490− ( a ~ Maybe Integer, b ~ Maybe Integer

491− ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

492− labelOptic = #paramSchema % #maxItems

493− {-# INLINE labelOptic #-}

494−

495−-- #minItems

496−

497−instance

498− ( a ~ Maybe Integer, b ~ Maybe Integer

499− ) => LabelOptic "minItems" A_Lens Header Header a b where

500− labelOptic = #paramSchema % #minItems

501− {-# INLINE labelOptic #-}

502−

503−instance

504− ( a ~ Maybe Integer, b ~ Maybe Integer

505− ) => LabelOptic "minItems" A_Lens Schema Schema a b where

506− labelOptic = #paramSchema % #minItems

507− {-# INLINE labelOptic #-}

508−

509−instance

510− ( a ~ Maybe Integer, b ~ Maybe Integer

511− ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where

512− labelOptic = #paramSchema % #minItems

513− {-# INLINE labelOptic #-}

514−

515−instance

516− ( a ~ Maybe Integer, b ~ Maybe Integer

517− ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

518− labelOptic = #paramSchema % #minItems

519− {-# INLINE labelOptic #-}

520−

521−-- #uniqueItems

522−

523−instance

524− ( a ~ Maybe Bool, b ~ Maybe Bool

525− ) => LabelOptic "uniqueItems" A_Lens Header Header a b where

526− labelOptic = #paramSchema % #uniqueItems

527− {-# INLINE labelOptic #-}

528−

529−instance

530− ( a ~ Maybe Bool, b ~ Maybe Bool

531− ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where

532− labelOptic = #paramSchema % #uniqueItems

533− {-# INLINE labelOptic #-}

534−

535−instance

536− ( a ~ Maybe Bool, b ~ Maybe Bool

537− ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where

538− labelOptic = #paramSchema % #uniqueItems

539− {-# INLINE labelOptic #-}

540−

541−instance

542− ( a ~ Maybe Bool, b ~ Maybe Bool

543− ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

544− labelOptic = #paramSchema % #uniqueItems

545− {-# INLINE labelOptic #-}

546−

547−-- #enum

548−

549−instance

550− ( a ~ Maybe [Value], b ~ Maybe [Value]

551− ) => LabelOptic "enum" A_Lens Header Header a b where

552− labelOptic = #paramSchema % #enum

553− {-# INLINE labelOptic #-}

554−

555−instance

556− ( a ~ Maybe [Value], b ~ Maybe [Value]

557− ) => LabelOptic "enum" A_Lens Schema Schema a b where

558− labelOptic = #paramSchema % #enum

559− {-# INLINE labelOptic #-}

560−

561−instance

562− ( a ~ Maybe [Value], b ~ Maybe [Value]

563− ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where

564− labelOptic = #paramSchema % #enum

565− {-# INLINE labelOptic #-}

566−

567−instance

568− ( a ~ Maybe [Value], b ~ Maybe [Value]

569− ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where

570− labelOptic = #paramSchema % #enum

571− {-# INLINE labelOptic #-}

572−

573−-- #multipleOf

574−

575−instance

576− ( a ~ Maybe Scientific, b ~ Maybe Scientific

577− ) => LabelOptic "multipleOf" A_Lens Header Header a b where

578− labelOptic = #paramSchema % #multipleOf

579− {-# INLINE labelOptic #-}

580−

581−instance

582− ( a ~ Maybe Scientific, b ~ Maybe Scientific

583− ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where

584− labelOptic = #paramSchema % #multipleOf

585− {-# INLINE labelOptic #-}

586−

587−instance

588− ( a ~ Maybe Scientific, b ~ Maybe Scientific

589− ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where

590− labelOptic = #paramSchema % #multipleOf

591− {-# INLINE labelOptic #-}

592−

593−instance

594− ( a ~ Maybe Scientific, b ~ Maybe Scientific

595− ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where

596− labelOptic = #paramSchema % #multipleOf

597− {-# INLINE labelOptic #-}

src/Data/Swagger/Schema/Generator.hsdeleted−114

@@ -1,114 +0,0 @@

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE OverloadedLists #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−

5−module Data.Swagger.Schema.Generator where

6−

7−import Prelude ()

8−import Prelude.Compat

9−

10−import Control.Lens.Operators

11−import Control.Monad (filterM)

12−import Data.Aeson

13−import Data.Aeson.Types

14−import qualified Data.HashMap.Strict.InsOrd as M

15−import Data.Maybe

16−import Data.Maybe

17−import Data.Proxy

18−import Data.Scientific

19−import qualified Data.Set as S

20−import Data.Swagger

21−import Data.Swagger.Declare

22−import Data.Swagger.Internal.Schema.Validation (inferSchemaTypes)

23−import qualified Data.Text as T

24−import qualified Data.Vector as V

25−import Test.QuickCheck (arbitrary)

26−import Test.QuickCheck.Gen

27−import Test.QuickCheck.Property

28−

29−-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30−-- and cannot be inferred.

31−schemaGen :: Definitions Schema -> Schema -> Gen Value

32−schemaGen _ schema

33− | Just cases <- schema ^. paramSchema . enum_ = elements cases

34−schemaGen defns schema =

35− case schema ^. type_ of

36− Nothing ->

37− case inferSchemaTypes schema of

38− [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

39− -- Gen is not MonadFail

40− _ -> error "unable to infer schema type"

41− Just SwaggerBoolean -> Bool <$> elements [True, False]

42− Just SwaggerNull -> pure Null

43− Just SwaggerNumber

44− | Just min <- schema ^. minimum_

45− , Just max <- schema ^. maximum_ ->

46− Number . fromFloatDigits <$>

47− choose (toRealFloat min, toRealFloat max :: Double)

48− | otherwise -> Number .fromFloatDigits <$> (arbitrary :: Gen Double)

49− Just SwaggerInteger

50− | Just min <- schema ^. minimum_

51− , Just max <- schema ^. maximum_ ->

52− Number . fromInteger <$>

53− choose (truncate min, truncate max)

54− | otherwise -> Number . fromInteger <$> arbitrary

55− Just SwaggerArray

56− | Just 0 <- schema ^. maxLength -> pure $ Array V.empty

57− | Just items <- schema ^. items ->

58− case items of

59− SwaggerItemsObject ref -> do

60− size <- getSize

61− let itemSchema = dereference defns ref

62− minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minItems

63− maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxItems

64− arrayLength <- choose (minLength', max minLength' maxLength')

65− generatedArray <- vectorOf arrayLength $ schemaGen defns itemSchema

66− return . Array $ V.fromList generatedArray

67− SwaggerItemsArray refs ->

68− let itemGens = schemaGen defns . dereference defns <$> refs

69− in fmap (Array . V.fromList) $ sequence itemGens

70− Just SwaggerString -> do

71− size <- getSize

72− let minLength' = fromMaybe 0 $ fromInteger <$> schema ^. minLength

73− let maxLength' = fromMaybe size $ fromInteger <$> schema ^. maxLength

74− length <- choose (minLength', max minLength' maxLength')

75− str <- vectorOf length arbitrary

76− return . String $ T.pack str

77− Just SwaggerObject -> do

78− size <- getSize

79− let props = dereference defns <$> schema ^. properties

80− reqKeys = S.fromList $ schema ^. required

81− allKeys = S.fromList . M.keys $ schema ^. properties

82− optionalKeys = allKeys S.\\ reqKeys

83− minProps' = fromMaybe (length reqKeys) $

84− fromInteger <$> schema ^. minProperties

85− maxProps' = fromMaybe size $ fromInteger <$> schema ^. maxProperties

86− shuffledOptional <- shuffle $ S.toList optionalKeys

87− numProps <- choose (minProps', max minProps' maxProps')

88− let presentKeys = take numProps $ S.toList reqKeys ++ shuffledOptional

89− let presentProps = M.filterWithKey (\k _ -> k `elem` presentKeys) props

90− let gens = schemaGen defns <$> presentProps

91− additionalGens <- case schema ^. additionalProperties of

92− Just (AdditionalPropertiesSchema addlSchema) -> do

93− additionalKeys <- sequence . take (numProps - length presentProps) . repeat $ T.pack <$> arbitrary

94− return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema)

95− _ -> return []

96− x <- sequence $ gens <> additionalGens

97− return . Object $ M.toHashMap x

98− where

99− dereference :: Definitions a -> Referenced a -> a

100− dereference _ (Inline a) = a

101− dereference defs (Ref (Reference ref)) = fromJust $ M.lookup ref defs

102−

103−genValue :: (ToSchema a) => Proxy a -> Gen Value

104−genValue p =

105− let (defs, NamedSchema _ schema) = runDeclare (declareNamedSchema p) M.empty

106− in schemaGen defs schema

107−

108−validateFromJSON :: forall a . (ToSchema a, FromJSON a) => Proxy a -> Property

109−validateFromJSON p = forAll (genValue p) $

110− \val -> case parseEither parseJSON val of

111− Right (_ :: a) -> succeeded

112− Left err -> failed

113− { reason = err

114− }

src/Data/Swagger/Schema/Validation.hs−2

@@ -19,10 +19,8 @@ module Data.Swagger.Schema.Validation (

1919 ValidationError,

2020

2121 -- ** Using 'ToJSON' and 'ToSchema'

22− validatePrettyToJSON,

2322 validateToJSON,

2423 validateToJSONWithPatternChecker,

25− renderValidationErrors,

2624

2725 -- ** Using 'Value' and 'Schema'

2826 validateJSON,

stack.yaml+3−6

@@ -1,9 +1,6 @@

1−resolver: lts-14.3

1+resolver: lts-12.10

22packages:

33- '.'

44extra-deps:

5−- optics-core-0.2

6−- optics-th-0.2

7−- optics-extra-0.2

8−- indexed-profunctors-0.1

9−- insert-ordered-containers-0.2.3

5+- base-compat-batteries-0.10.4

6+- contravariant-1.5

swagger2.cabal+25−30

@@ -1,11 +1,12 @@

11cabal-version: >=1.10

22name: swagger2

3−version: 2.5

3+version: 2.3.0.1

4+x-revision: 1

56synopsis: Swagger 2.0 data model

67category: Web, Swagger

78description:

8− This library is intended to be used for decoding and encoding Swagger 2.0 API

9+ This library is inteded to be used for decoding and encoding Swagger 2.0 API

910 specifications as well as manipulating them.

1011 .

1112 The original Swagger 2.0 specification is available at http://swagger.io/specification/.

@@ -24,15 +25,16 @@ extra-source-files:

2425 , examples/*.hs

2526 , include/overlapping-compat.h

2627tested-with:

27− GHC ==8.0.2

28+ GHC ==7.8.4

29+ || ==7.10.3

30+ || ==8.0.2

2831 || ==8.2.2

2932 || ==8.4.4

30− || ==8.6.5

31− || ==8.8.1

33+ || ==8.6.1

3234

3335custom-setup

3436 setup-depends:

35− base, Cabal, cabal-doctest >=1.0.6 && <1.1

37+ base, Cabal, cabal-doctest >=1.0.2 && <1.1

3638

3739library

3840 hs-source-dirs: src

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

4244 Data.Swagger.Declare

4345 Data.Swagger.Lens

4446 Data.Swagger.Operation

45− Data.Swagger.Optics

4647 Data.Swagger.ParamSchema

4748 Data.Swagger.Schema

48− Data.Swagger.Schema.Generator

4949 Data.Swagger.Schema.Validation

5050 Data.Swagger.SchemaOptions

5151

@@ -60,12 +60,11 @@ library

6060

6161 -- GHC boot libraries

6262 build-depends:

63− base >=4.9 && <4.14

64− , aeson-pretty >=0.8.7 && <0.9

63+ base >=4.7 && <4.13

6564 , bytestring >=0.10.4.0 && <0.11

6665 , containers >=0.5.5.1 && <0.7

67− , template-haskell >=2.9.0.0 && <2.16

68− , time >=1.4.2 && <1.10

66+ , template-haskell >=2.9.0.0 && <2.15

67+ , time >=1.4.2 && <1.9

6968 , transformers >=0.3.0.0 && <0.6

7069

7170 build-depends:

@@ -74,24 +73,19 @@ library

7473

7574 -- other dependencies

7675 build-depends:

77− base-compat-batteries >=0.10.4 && <0.12

78− , aeson >=1.4.2.0 && <1.5

79− -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

80− , cookie >=0.4.3 && <0.5

81− , generics-sop >=0.3.2.0 && <0.6

82− , hashable >=1.2.7.0 && <1.4

83− , http-media >=0.7.1.2 && <0.9

84− , insert-ordered-containers >=0.2.3 && <0.3

85− , lens >=4.16.1 && <4.19

86− , network >=2.6.3.5 && <3.2

87− , optics-core >=0.2 && <0.3

88− , optics-th >=0.2 && <0.3

76+ base-compat-batteries >=0.10.4 && <0.11

77+ , aeson >=1.3.1.1 && <1.5

78+ , generics-sop >=0.3.2.0 && <0.4

79+ , hashable >=1.2.7.0 && <1.3

80+ , http-media >=0.7.1.2 && <0.8

81+ , insert-ordered-containers >=0.2.1.0 && <0.3

82+ , lens >=4.16.1 && <4.18

83+ , network >=2.6.3.5 && <2.9

8984 , scientific >=0.3.6.2 && <0.4

9085 , transformers-compat >=0.3 && <0.7

9186 , unordered-containers >=0.2.9.0 && <0.3

9287 , uuid-types >=1.0.3 && <1.1

9388 , vector >=0.12.0.1 && <0.13

94− , QuickCheck >=2.10.1 && <2.14

9589

9690 default-language: Haskell2010

9791

@@ -102,7 +96,7 @@ test-suite spec

10296

10397 -- From library parat

10498 -- We need aeson's toEncoding for doctests too

105− build-depends:

99+ build-depends:

106100 base

107101 , swagger2

108102 , aeson

@@ -118,18 +112,18 @@ test-suite spec

118112 , time

119113 , unordered-containers

120114 , vector

121− , QuickCheck

122115

123116 -- test-suite only dependencies

124117 build-depends:

125− hspec >=2.5.5 && <2.8

118+ hspec >=2.5.5 && <2.6

126119 , HUnit >=1.6.0.0 && <1.7

120+ , QuickCheck >=2.11.3 && <2.13

127121 , quickcheck-instances >=0.3.19 && <0.14

128122 , utf8-string >=1.0.1.1 && <1.1

129123

130124 -- https://github.com/haskell/cabal/issues/3708

131125 build-tool-depends:

132− hspec-discover:hspec-discover >=2.5.5 && <2.8

126+ hspec-discover:hspec-discover >=2.5.5 && <2.6

133127

134128 other-modules:

135129 SpecCommon

@@ -138,7 +132,8 @@ test-suite spec

138132 Data.Swagger.ParamSchemaSpec

139133 Data.Swagger.SchemaSpec

140134 Data.Swagger.Schema.ValidationSpec

141− Data.Swagger.Schema.GeneratorSpec

135+

136+ Data.Aeson.QQ.Simple

142137 default-language: Haskell2010

143138

144139test-suite doctests

test/Data/Aeson/QQ/Simple.hsnew file+45

@@ -0,0 +1,45 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+-- | Like "Data.Aeson.QQ" but without interpolation.

3+module Data.Aeson.QQ.Simple where

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+4−31

@@ -18,6 +18,8 @@ import qualified Data.Text as Text

1818import GHC.Generics

1919

2020import Data.Swagger

21+import Data.Swagger.Declare

22+import Data.Swagger.Internal (SwaggerKind (..))

2123

2224-- ========================================================================

2325-- Unit type

@@ -550,7 +552,7 @@ lightSchemaJSON = [aesonQQ|

550552 "type": "object",

551553 "properties":

552554 {

553− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

555+ "NoLight": { "type": "array", "items": [] },

554556 "LightFreq": { "type": "number", "format": "double" },

555557 "LightColor": { "$ref": "#/definitions/Color" },

556558 "LightWaveLength": { "type": "number", "format": "double" }

@@ -566,7 +568,7 @@ lightInlinedSchemaJSON = [aesonQQ|

566568 "type": "object",

567569 "properties":

568570 {

569− "NoLight": { "type": "array", "items": {}, "maxItems": 0, "example": [] },

571+ "NoLight": { "type": "array", "items": [] },

570572 "LightFreq": { "type": "number", "format": "double" },

571573 "LightColor":

572574 {

@@ -648,32 +650,3 @@ singleMaybeFieldSchemaJSON = [aesonQQ|

648650 }

649651}

650652|]

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+1−6

@@ -3,10 +3,9 @@

33{-# LANGUAGE ScopedTypeVariables #-}

44{-# LANGUAGE TemplateHaskell #-}

55{-# LANGUAGE QuasiQuotes #-}

6−{-# LANGUAGE OverloadedStrings #-}

76module Data.Swagger.ParamSchemaSpec where

9−import Data.Aeson

8+import Data.Aeson (Value)

109import Data.Aeson.QQ.Simple

1110import Data.Char

1211import Data.Proxy

@@ -18,9 +17,6 @@ import Data.Swagger.Internal (SwaggerKind(..))

1817import Data.Swagger.CommonTestTypes

1918import SpecCommon

2019import Test.Hspec

21−import Data.Time.LocalTime

22−

23−import qualified Data.HashMap.Strict as HM

2420

2521checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

2622checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

@@ -34,7 +30,6 @@ spec = do

3430 context "Unary records" $ do

3531 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

3632 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

3833

3934main :: IO ()

4035main = hspec spec

test/Data/Swagger/Schema/GeneratorSpec.hsdeleted−168

@@ -1,168 +0,0 @@

1−{-# LANGUAGE OverloadedLists #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE PackageImports #-}

4−module Data.Swagger.Schema.GeneratorSpec where

5−

6−import Prelude ()

7−import Prelude.Compat

8−

9−import Data.Swagger

10−import Data.Swagger.Schema.Generator

11−

12−import Control.Lens.Operators

13−import Data.Aeson

14−import Data.Hashable (Hashable)

15−import Data.HashMap.Strict (HashMap)

16−import qualified Data.HashMap.Strict as HashMap

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

18−import qualified "unordered-containers" Data.HashSet as HashSet

19−import Data.Int

20−import Data.IntMap (IntMap)

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

22−import Data.Map (Map, fromList)

23−import Data.Monoid (mempty)

24−import Data.Proxy

25−import Data.Proxy

26−import Data.Set (Set)

27−import qualified Data.Text as T

28−import qualified Data.Text.Lazy as TL

29−import Data.Time

30−import Data.Version (Version)

31−import Data.Word

32−import GHC.Generics

33−

34−import Test.Hspec

35−import Test.Hspec.QuickCheck

36−import Test.QuickCheck

37−

38−shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

39−shouldValidate = validateFromJSON

40−

41−

42−shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property

43−shouldNotValidate = expectFailure . shouldValidate

44−

45−

46−spec :: Spec

47−spec = do

48− describe "FromJSON validation" $ do

49− prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)

50− prop "Char" $ shouldValidate (Proxy :: Proxy Char)

51− prop "Double" $ shouldValidate (Proxy :: Proxy Double)

52− prop "Float" $ shouldValidate (Proxy :: Proxy Float)

53− prop "Int" $ shouldValidate (Proxy :: Proxy Int)

54− prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)

55− prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)

56− prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)

57− prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)

58− prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)

59− prop "Word" $ shouldValidate (Proxy :: Proxy Word)

60− prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)

61− prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)

62− prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)

63− prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)

64− prop "String" $ shouldValidate (Proxy :: Proxy String)

65− prop "()" $ shouldValidate (Proxy :: Proxy ())

66−-- prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)

67−-- prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)

68− prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)

69− prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)

70− prop "[String]" $ shouldValidate (Proxy :: Proxy [String])

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

72− prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))

73− prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))

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

75− prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))

76− prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))

77− prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))

78− prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))

79− prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))

80− prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))

81− prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))

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

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

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

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

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

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

88− describe "Invalid FromJSON validation" $ do

89− prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)

90− prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)

91− prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)

92− prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)

93−

94−-- =============================

95−-- Data types and bunk instances

96−-- =============================

97−

98−data WrongType = WrongType Bool

99−

100−instance FromJSON WrongType where

101− parseJSON = withBool "WrongType" $ return . WrongType

102−

103−instance ToSchema WrongType where

104− declareNamedSchema _ = return . NamedSchema (Just "WrongType") $

105− mempty

106− & type_ ?~ SwaggerObject

107−

108−

109−data MissingRequired = MissingRequired

110− { propA :: String

111− , propB :: Bool

112− }

113−

114−instance FromJSON MissingRequired where

115− parseJSON = withObject "MissingRequired" $ \o ->

116− MissingRequired

117− <$> o .: "propA"

118− <*> o .: "propB"

119−

120−instance ToSchema MissingRequired where

121− declareNamedSchema _ = do

122− stringSchema <- declareSchemaRef (Proxy :: Proxy String)

123− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

124− return . NamedSchema (Just "MissingRequired") $

125− mempty

126− & type_ ?~ SwaggerObject

127− & properties .~ [("propA", stringSchema)

128− ,("propB", boolSchema)

129− ]

130− & required .~ ["propA"]

131−

132−data MissingProperty = MissingProperty

133− { propC :: String

134− , propD :: Bool

135− }

136−

137−instance FromJSON MissingProperty where

138− parseJSON = withObject "MissingProperty" $ \o ->

139− MissingProperty

140− <$> o .: "propC"

141− <*> o .: "propD"

142−

143−instance ToSchema MissingProperty where

144− declareNamedSchema _ = do

145− stringSchema <- declareSchemaRef (Proxy :: Proxy String)

146− return . NamedSchema (Just "MissingProperty") $

147− mempty

148− & type_ ?~ SwaggerObject

149− & properties .~ [("propC", stringSchema)]

150− & required .~ ["propC"]

151−

152−data WrongPropType = WrongPropType

153− { propE :: String

154− }

155−

156−instance FromJSON WrongPropType where

157− parseJSON = withObject "WrongPropType" $ \o ->

158− WrongPropType

159− <$> o .: "propE"

160−

161−instance ToSchema WrongPropType where

162− declareNamedSchema _ = do

163− boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)

164− return . NamedSchema (Just "WrongPropType") $

165− mempty

166− & type_ ?~ SwaggerObject

167− & properties .~ [("propE", boolSchema)]

168− & required .~ ["propE"]

test/Data/Swagger/Schema/ValidationSpec.hs+1−1

@@ -248,7 +248,7 @@ instance ToJSON FreeForm where

248248

249249instance ToSchema FreeForm where

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

251− & type_ ?~ SwaggerObject

251+ & type_ .~ SwaggerObject

252252 & additionalProperties ?~ AdditionalPropertiesAllowed True

253253

254254instance Arbitrary FreeForm where

test/Data/Swagger/SchemaSpec.hs+6−5

@@ -8,11 +8,16 @@ import Prelude ()

88import Prelude.Compat

1010import Control.Lens ((^.))

11−import Data.Aeson (Value)

11+import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))

12+import Data.Aeson.Types (toJSONKeyText)

13+import Data.Aeson.QQ.Simple

14+import Data.Char

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

1316import Data.Proxy

1417import Data.Set (Set)

18+import Data.Map (Map)

1519import qualified Data.Text as Text

20+import GHC.Generics

1621

1722import Data.Swagger

1823import Data.Swagger.Declare

@@ -21,9 +26,6 @@ import Data.Swagger.CommonTestTypes

2126import SpecCommon

2227import Test.Hspec

2328

24−import qualified Data.HashMap.Strict as HM

25−import Data.Time.LocalTime

26−

2729checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

2830checkToSchema proxy js = toSchema proxy <=> js

2931

@@ -108,7 +110,6 @@ spec = do

108110 context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

109111 describe "Bounded Enum key mapping" $ do

110112 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

111− context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON

112113

113114main :: IO ()

114115main = hspec spec

test/Data/SwaggerSpec.hs+31−72

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

1212import Data.Aeson

1313import Data.Aeson.QQ.Simple

1414import Data.HashMap.Strict (HashMap)

15−import qualified Data.HashSet.InsOrd as InsOrdHS

15+import qualified Data.Set as Set

1616import Data.Text (Text)

1717

1818import Data.Swagger

@@ -43,7 +43,6 @@ spec = do

4343 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

4444 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

4545 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46− describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

4746 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

4847 describe "Swagger Object" $ do

4948 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

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

128127

129128operationExample :: Operation

130129operationExample = mempty

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

130+ & tags .~ Set.fromList ["pet"]

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

133132 & description ?~ ""

134133 & operationId ?~ "updatePetWithForm"

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

159158 stringSchema :: ParamLocation -> ParamOtherSchema

160159 stringSchema loc = mempty

161160 & in_ .~ loc

162− & type_ ?~ SwaggerString

161+ & type_ .~ SwaggerString

163162

164163operationExampleJSON :: Value

165164operationExampleJSON = [aesonQQ|

@@ -225,7 +224,7 @@ operationExampleJSON = [aesonQQ|

225224

226225schemaPrimitiveExample :: Schema

227226schemaPrimitiveExample = mempty

228− & type_ ?~ SwaggerString

227+ & type_ .~ SwaggerString

229228 & format ?~ "email"

230229

231230schemaPrimitiveExampleJSON :: Value

@@ -238,14 +237,14 @@ schemaPrimitiveExampleJSON = [aesonQQ|

238237

239238schemaSimpleModelExample :: Schema

240239schemaSimpleModelExample = mempty

241− & type_ ?~ SwaggerObject

240+ & type_ .~ SwaggerObject

242241 & required .~ [ "name" ]

243242 & properties .~

244− [ ("name", Inline (mempty & type_ ?~ SwaggerString))

243+ [ ("name", Inline (mempty & type_ .~ SwaggerString))

245244 , ("address", Ref (Reference "Address"))

246245 , ("age", Inline $ mempty

247246 & minimum_ ?~ 0

248− & type_ ?~ SwaggerInteger

247+ & type_ .~ SwaggerInteger

249248 & format ?~ "int32" ) ]

250249

251250schemaSimpleModelExampleJSON :: Value

@@ -273,8 +272,8 @@ schemaSimpleModelExampleJSON = [aesonQQ|

273272

274273schemaModelDictExample :: Schema

275274schemaModelDictExample = mempty

276− & type_ ?~ SwaggerObject

277− & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ ?~ SwaggerString))

275+ & type_ .~ SwaggerObject

276+ & additionalProperties ?~ AdditionalPropertiesSchema (Inline (mempty & type_ .~ SwaggerString))

278277

279278schemaModelDictExampleJSON :: Value

280279schemaModelDictExampleJSON = [aesonQQ|

@@ -288,7 +287,7 @@ schemaModelDictExampleJSON = [aesonQQ|

288287

289288schemaAdditionalExample :: Schema

290289schemaAdditionalExample = mempty

291− & type_ ?~ SwaggerObject

290+ & type_ .~ SwaggerObject

292291 & additionalProperties ?~ AdditionalPropertiesAllowed True

293292

294293schemaAdditionalExampleJSON :: Value

@@ -301,13 +300,13 @@ schemaAdditionalExampleJSON = [aesonQQ|

301300

302301schemaWithExampleExample :: Schema

303302schemaWithExampleExample = mempty

304− & type_ ?~ SwaggerObject

303+ & type_ .~ SwaggerObject

305304 & properties .~

306305 [ ("id", Inline $ mempty

307− & type_ ?~ SwaggerInteger

306+ & type_ .~ SwaggerInteger

308307 & format ?~ "int64" )

309308 , ("name", Inline $ mempty

310− & type_ ?~ SwaggerString) ]

309+ & type_ .~ SwaggerString) ]

311310 & required .~ [ "name" ]

312311 & example ?~ [aesonQQ|

313312 {

@@ -346,19 +345,19 @@ schemaWithExampleExampleJSON = [aesonQQ|

346345definitionsExample :: HashMap Text Schema

347346definitionsExample =

348347 [ ("Category", mempty

349− & type_ ?~ SwaggerObject

348+ & type_ .~ SwaggerObject

350349 & properties .~

351350 [ ("id", Inline $ mempty

352− & type_ ?~ SwaggerInteger

351+ & type_ .~ SwaggerInteger

353352 & format ?~ "int64")

354− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] )

353+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] )

355354 , ("Tag", mempty

356− & type_ ?~ SwaggerObject

355+ & type_ .~ SwaggerObject

357356 & properties .~

358357 [ ("id", Inline $ mempty

359− & type_ ?~ SwaggerInteger

358+ & type_ .~ SwaggerInteger

360359 & format ?~ "int64")

361− , ("name", Inline (mempty & type_ ?~ SwaggerString)) ] ) ]

360+ , ("name", Inline (mempty & type_ .~ SwaggerString)) ] ) ]

362361

363362definitionsExampleJSON :: Value

364363definitionsExampleJSON = [aesonQQ|

@@ -402,7 +401,7 @@ paramsDefinitionExample =

402401 & required ?~ True

403402 & schema .~ ParamOther (mempty

404403 & in_ .~ ParamQuery

405− & type_ ?~ SwaggerInteger

404+ & type_ .~ SwaggerInteger

406405 & format ?~ "int32" ))

407406 , ("limitParam", mempty

408407 & name .~ "limit"

@@ -410,7 +409,7 @@ paramsDefinitionExample =

410409 & required ?~ True

411410 & schema .~ ParamOther (mempty

412411 & in_ .~ ParamQuery

413− & type_ ?~ SwaggerInteger

412+ & type_ .~ SwaggerInteger

414413 & format ?~ "int32" )) ]

415414

416415paramsDefinitionExampleJSON :: Value

@@ -460,8 +459,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

460459-- Responses Definition object

461460-- =======================================================================

462461

463−securityDefinitionsExample :: SecurityDefinitions

464−securityDefinitionsExample = SecurityDefinitions

462+securityDefinitionsExample :: HashMap Text SecurityScheme

463+securityDefinitionsExample =

465464 [ ("api_key", SecurityScheme

466465 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

467466 , _securitySchemeDescription = Nothing })

@@ -493,46 +492,6 @@ securityDefinitionsExampleJSON = [aesonQQ|

493492}

494493|]

495494

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−

536495-- =======================================================================

537496-- Swagger object

538497-- =======================================================================

@@ -551,7 +510,7 @@ swaggerExample = mempty

551510 & at 200 ?~ Inline (mempty

552511 & description .~ "OK"

553512 & schema ?~ Inline (mempty

554− & type_ ?~ SwaggerObject

513+ & type_ .~ SwaggerObject

555514 & example ?~ [aesonQQ|

556515 {

557516 "created": 100,

@@ -560,9 +519,9 @@ swaggerExample = mempty

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

561520 & properties .~

562521 [ ("created", Inline $ mempty

563− & type_ ?~ SwaggerInteger

522+ & type_ .~ SwaggerInteger

564523 & format ?~ "int32")

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

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

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

567526 & parameters .~

568527 [ Inline $ mempty

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

571530 & description ?~ "TodoId param"

572531 & schema .~ ParamOther (mempty

573532 & in_ .~ ParamPath

574− & type_ ?~ SwaggerString ) ]

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

533+ & type_ .~ SwaggerString ) ]

534+ & tags .~ Set.fromList [ "todo" ] ))

576535

577536swaggerExampleJSON :: Value

578537swaggerExampleJSON = [aesonQQ|

@@ -1673,14 +1632,14 @@ petstoreExampleJSON = [aesonQQ|

16731632

16741633compositionSchemaExample :: Schema

16751634compositionSchemaExample = mempty

1676− & type_ ?~ SwaggerObject

1635+ & type_ .~ SwaggerObject

16771636 & Data.Swagger.allOf ?~ [

16781637 Ref (Reference "Other")

16791638 , Inline (mempty

1680− & type_ ?~ SwaggerObject

1639+ & type_ .~ SwaggerObject

16811640 & properties .~

16821641 [ ("greet", Inline $ mempty

1683− & type_ ?~ SwaggerString) ])

1642+ & type_ .~ SwaggerString) ])

16841643 ]

16851644

16861645compositionSchemaExampleJSON :: Value