6448fcf...master · typeable/swagger2

git.iko.soy/typeable/swagger2

.ghci+1

since splitsnapshots

@@ -1 +1,2 @@

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

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

.travis.yml+55−42

@@ -4,7 +4,7 @@

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

7−# version: 0.3.20190413

7+# version: 0.5.20191020

9language: c

10dist: xenial

@@ -29,27 +29,27 @@ before_cache:

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

30matrix:

31 include:

32− - compiler: ghc-8.6.4

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

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

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

34 - compiler: ghc-8.4.4

36 - compiler: ghc-8.4.4

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

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

36 - compiler: ghc-8.2.2

38 - compiler: ghc-8.2.2

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

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

38 - compiler: ghc-8.0.2

40 - compiler: ghc-8.0.2

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

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

40− - compiler: ghc-7.10.3

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

42− - compiler: ghc-7.8.4

43− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4"]}}

44before_install:

42before_install:

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

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

44+ - WITHCOMPILER="-w $HC"

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

46 - HCPKG="$HC-pkg"

47 - unset CC

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

49 - CABALHOME=$HOME/.cabal

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

51 - TOP=$(pwd)

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

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

53 - echo $HCNUMVER

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

55 - set -o pipefail

@@ -76,22 +76,35 @@ install:

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

77 - TEST=--enable-tests

78 - BENCH=--enable-benchmarks

79− - GHCHEAD=${GHCHEAD-false}

79+ - HEADHACKAGE=false

80 - rm -f $CABALHOME/config

81 - |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

94− echo " url: http://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

95 - cat $CABALHOME/config

108 - cat $CABALHOME/config

96 - rm -fv cabal.project cabal.project.local cabal.project.freeze

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

97 - travis_retry ${CABAL} v2-update -v

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

@@ -99,18 +112,17 @@ install:

99 - rm -rf cabal.project cabal.project.local cabal.project.freeze

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

100 - touch cabal.project

113 - touch cabal.project

101 - |

114 - |

102− echo 'packages: "."' >> cabal.project

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

103 - |

116 - |

104− echo "write-ghc-environment-files: always" >> cabal.project

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

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"

106 - cat cabal.project || true

118 - cat cabal.project || true

107 - cat cabal.project.local || true

119 - cat cabal.project.local || true

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

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

109− - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output

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

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

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

111 - rm cabal.project.freeze

123 - rm cabal.project.freeze

112− - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output

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

113− - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output

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

114script:

126script:

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

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

116 # Packaging...

128 # Packaging...

@@ -118,32 +130,33 @@ script:

118 # Unpacking...

130 # Unpacking...

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

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

120 - cd ${DISTDIR} || false

132 - cd ${DISTDIR} || false

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

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

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

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

122 # Generate cabal.project

136 # Generate cabal.project

123 - rm -rf cabal.project cabal.project.local cabal.project.freeze

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

124 - touch cabal.project

138 - touch cabal.project

125 - |

139 - |

126− echo 'packages: "swagger2-*/*.cabal"' >> cabal.project

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

127 - |

141 - |

128− echo "write-ghc-environment-files: always" >> cabal.project

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

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"

130 - cat cabal.project || true

143 - cat cabal.project || true

131 - cat cabal.project.local || true

144 - cat cabal.project.local || true

132 # Building...

145 # Building...

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

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

134− - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output

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

135 # Building with tests and benchmarks...

148 # Building with tests and benchmarks...

136 # build & run tests, build benchmarks

149 # build & run tests, build benchmarks

137− - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output

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

138 # Testing...

151 # Testing...

139− - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output

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

140 # cabal check...

153 # cabal check...

141− - (cd swagger2-* && ${CABAL} -vnormal check)

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

142 # haddock...

155 # haddock...

143− - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output ; fi

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

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

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

145 - rm -f cabal.project.local

158 - rm -f cabal.project.local

146− - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output

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

147

160

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

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

149# EOF

162# EOF

CHANGELOG.md+26

@@ -1,5 +1,31 @@

1+2.5

2+---

4+Highlights:

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

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

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

9+Fixes and minor changes:

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

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

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

13+

14+2.4

15+---

16+

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

18+- Tags aren't sorted

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

20+- Schema type is optional

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

22+- Take concrete 'Proxy' as argument

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

24+- GHC-8.8 preparations

25+

12.3.1.1

262.3.1.1

2-------

27-------

28+

3- Allow `network-3.0`

29- Allow `network-3.0`

52.3.1

312.3.1

cabal.projectnew file+2

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

1+packages: .

2+tests: true

examples/hackage.hs+1−1

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

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

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

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

30− & type_ .~ SwaggerObject

30+ & type_ ?~ SwaggerObject

31 & properties .~

32 [ ("summaryUsername", usernameSchema )

33 , ("summaryUserid" , useridSchema )

src/Data/Swagger.hs+6−1

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

32 -- * Re-exports

33 module Data.Swagger.Lens,

34+ module Data.Swagger.Optics,

34 module Data.Swagger.Operation,

35 module Data.Swagger.Operation,

35 module Data.Swagger.ParamSchema,

36 module Data.Swagger.ParamSchema,

36 module Data.Swagger.Schema,

37 module Data.Swagger.Schema,

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

88 SecurityScheme(..),

89 SecurityScheme(..),

89 SecuritySchemeType(..),

90 SecuritySchemeType(..),

90 SecurityRequirement(..),

91 SecurityRequirement(..),

92+ SecurityDefinitions(..),

92 -- *** API key

94 -- *** API key

93 ApiKeyParams(..),

95 ApiKeyParams(..),

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

112) where

114) where

113

115

114import Data.Swagger.Lens

116import Data.Swagger.Lens

117+import Data.Swagger.Optics ()

115import Data.Swagger.Operation

118import Data.Swagger.Operation

116import Data.Swagger.ParamSchema

119import Data.Swagger.ParamSchema

117import Data.Swagger.Schema

120import Data.Swagger.Schema

@@ -175,6 +178,8 @@ import Data.Swagger.Internal

175

178

176-- $lens

179-- $lens

177--

180--

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

182+--

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

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

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

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

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

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

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

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

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

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

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

277--

282--

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

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

279-- schema for basic enums like

284-- schema for basic enums like

280--

285--

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

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

src/Data/Swagger/Internal.hs+47−6

@@ -29,13 +29,14 @@ import Control.Applicative

29import Data.Aeson

30import qualified Data.Aeson.Types as JSON

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

32+import Data.Hashable (Hashable)

32import qualified Data.HashMap.Strict as HashMap

33import qualified Data.HashMap.Strict as HashMap

34+import Data.HashSet.InsOrd (InsOrdHashSet)

33import Data.Map (Map)

35import Data.Map (Map)

34import qualified Data.Map as Map

36import qualified Data.Map as Map

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

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

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

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

37import Data.Scientific (Scientific)

39import Data.Scientific (Scientific)

38−import Data.Set (Set)

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

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

40import Data.Text (Text)

41import Data.Text (Text)

41import qualified Data.Text as Text

42import qualified Data.Text as Text

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

116 , _swaggerResponses :: Definitions Response

117 , _swaggerResponses :: Definitions Response

117

118

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

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

119− , _swaggerSecurityDefinitions :: Definitions SecurityScheme

120+ , _swaggerSecurityDefinitions :: SecurityDefinitions

120

121

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

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

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

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

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

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

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

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

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

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

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

132− , _swaggerTags :: Set Tag

133+ , _swaggerTags :: InsOrdHashSet Tag

133

134

134 -- | Additional external documentation.

135 -- | Additional external documentation.

135 , _swaggerExternalDocs :: Maybe ExternalDocs

136 , _swaggerExternalDocs :: Maybe ExternalDocs

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

251data Operation = Operation

252data Operation = Operation

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

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

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

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

254− _operationTags :: Set TagName

255+ _operationTags :: InsOrdHashSet TagName

255

256

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

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

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

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

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

610 , _paramSchemaMultipleOf :: Maybe Scientific

611 , _paramSchemaMultipleOf :: Maybe Scientific

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

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

612

613

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

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

614

615

615data Xml = Xml

616data Xml = Xml

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

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

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

754 , _securitySchemeDescription :: Maybe Text

755 , _securitySchemeDescription :: Maybe Text

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

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

756

757

758+

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

760+-- In other case returns first security scheme

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

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

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

764+ = if flow1 == flow2 then

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

766+ else

767+ s1

768+mergeSecurityScheme s1 _ = s1

769+

770+newtype SecurityDefinitions

771+ = SecurityDefinitions (Definitions SecurityScheme)

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

773+

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

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

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

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

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

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

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

778 , _tagExternalDocs :: Maybe ExternalDocs

795 , _tagExternalDocs :: Maybe ExternalDocs

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

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

780

797

798+instance Hashable Tag

799+

781instance IsString Tag where

800instance IsString Tag where

782 fromString s = Tag (fromString s) Nothing Nothing

801 fromString s = Tag (fromString s) Nothing Nothing

783

802

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

791 , _externalDocsUrl :: URL

810 , _externalDocsUrl :: URL

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

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

793

812

813+instance Hashable ExternalDocs

814+

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

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

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

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

796newtype Reference = Reference { getReference :: Text }

817newtype Reference = Reference { getReference :: Text }

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

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

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

805 fromString = Inline . fromString

826 fromString = Inline . fromString

806

827

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

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

808

829

809data AdditionalProperties

830data AdditionalProperties

810 = AdditionalPropertiesAllowed Bool

831 = AdditionalPropertiesAllowed Bool

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

899 mempty = genericMempty

920 mempty = genericMempty

900 mappend = (<>)

921 mappend = (<>)

901

922

923+instance Semigroup SecurityScheme where

924+ (<>) = mergeSecurityScheme

925+

926+instance Semigroup SecurityDefinitions where

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

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

929+

930+instance Monoid SecurityDefinitions where

931+ mempty = SecurityDefinitions $ InsOrdHashMap.empty

932+ mappend = (<>)

933+

902-- =======================================================================

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

903-- SwaggerMonoid helper instances

935-- SwaggerMonoid helper instances

904-- =======================================================================

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

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

913instance SwaggerMonoid Response

945instance SwaggerMonoid Response

914instance SwaggerMonoid ExternalDocs

946instance SwaggerMonoid ExternalDocs

915instance SwaggerMonoid Operation

947instance SwaggerMonoid Operation

948+instance SwaggerMonoid SecurityDefinitions

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

916

950

917instance SwaggerMonoid MimeList

951instance SwaggerMonoid MimeList

918deriving instance SwaggerMonoid URL

952deriving instance SwaggerMonoid URL

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

1112instance ToJSON Example where

1146instance ToJSON Example where

1113 toJSON = toJSON . Map.mapKeys show . getExample

1147 toJSON = toJSON . Map.mapKeys show . getExample

1114

1148

1149+instance ToJSON SecurityDefinitions where

1150+ toJSON (SecurityDefinitions sd) = toJSON sd

1151+

1115instance ToJSON Reference where

1152instance ToJSON Reference where

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

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

1117

1154

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

1273instance FromJSON PathItem where

1310instance FromJSON PathItem where

1274 parseJSON = sopSwaggerGenericParseJSON

1311 parseJSON = sopSwaggerGenericParseJSON

1275

1312

1313+instance FromJSON SecurityDefinitions where

1314+ parseJSON js = SecurityDefinitions <$> parseJSON js

1315+

1276instance FromJSON Reference where

1316instance FromJSON Reference where

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

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

1278 parseJSON _ = empty

1318 parseJSON _ = empty

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

1384instance AesonDefaultValue MimeList where defaultValue = Just mempty

1424instance AesonDefaultValue MimeList where defaultValue = Just mempty

1385instance AesonDefaultValue Info

1425instance AesonDefaultValue Info

1386instance AesonDefaultValue ParamLocation

1426instance AesonDefaultValue ParamLocation

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

src/Data/Swagger/Internal/AesonUtils.hs+14

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

44import qualified Data.HashMap.Strict as HM

45import qualified Data.Set as Set

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

47+import qualified Data.HashSet.InsOrd as InsOrdHS

48#if MIN_VERSION_aeson(0,10,0)

49#if MIN_VERSION_aeson(0,10,0)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

144 -> DatatypeInfo '[xs]

146 -> DatatypeInfo '[xs]

145 -> POP Maybe '[xs]

147 -> POP Maybe '[xs]

146 -> [Pair]

148 -> [Pair]

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

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

151+#else

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

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

153+#endif

148 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs

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

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

150

156

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

220 -> DatatypeInfo '[xs]

226 -> DatatypeInfo '[xs]

221 -> POP Maybe '[xs]

227 -> POP Maybe '[xs]

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

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

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

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

231+#else

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

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

233+#endif

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

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

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

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

226

236

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

292 -> DatatypeInfo '[xs]

302 -> DatatypeInfo '[xs]

293 -> POP Maybe '[xs]

303 -> POP Maybe '[xs]

294 -> Series

304 -> Series

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

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

307+#else

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

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

309+#endif

296 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs

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

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

298

312

src/Data/Swagger/Internal/ParamSchema.hs+6

@@ -193,6 +193,12 @@ timeParamSchema fmt = mempty

193instance ToParamSchema Day where

194 toParamSchema _ = timeParamSchema "date"

195

196+-- |

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

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

199+instance ToParamSchema TimeOfDay where

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

201+

196-- |

202-- |

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

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

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

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

src/Data/Swagger/Internal/Schema.hs+5−1

@@ -147,6 +147,10 @@ class ToSchema a where

147 Proxy a -> Declare (Definitions Schema) NamedSchema

148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

149

150+instance ToSchema TimeOfDay where

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

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

153+

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

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

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

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

152declareSchema = fmap _namedSchemaSchema . declareNamedSchema

156declareSchema = fmap _namedSchemaSchema . declareNamedSchema

@@ -335,7 +339,7 @@ sketchSchema = sketch . toJSON

335

339

336 go Null = mempty & type_ ?~ SwaggerNull

340 go Null = mempty & type_ ?~ SwaggerNull

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

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

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

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

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

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

340 go (Array xs) = mempty

344 go (Array xs) = mempty

341 & type_ ?~ SwaggerArray

345 & type_ ?~ SwaggerArray

src/Data/Swagger/Internal/Schema/Validation.hs+127−42

@@ -22,23 +22,27 @@

22-- Validate JSON values with Swagger Schema.

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

25+import Prelude ()

26+import Prelude.Compat

27+

25import Control.Applicative

28import Control.Applicative

26import Control.Lens

29import Control.Lens

27import Control.Monad (when)

30import Control.Monad (when)

29import Data.Aeson hiding (Result)

32import Data.Aeson hiding (Result)

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

30import Data.Foldable (for_, sequenceA_,

34import Data.Foldable (for_, sequenceA_,

31 traverse_)

35 traverse_)

32import Data.HashMap.Strict (HashMap)

36import Data.HashMap.Strict (HashMap)

33import qualified Data.HashMap.Strict as HashMap

37import qualified Data.HashMap.Strict as HashMap

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

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

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

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

36−import Data.List (intercalate)

37−import Data.Monoid

38import Data.Proxy

40import Data.Proxy

39import Data.Scientific (Scientific, isInteger)

41import Data.Scientific (Scientific, isInteger)

40import Data.Text (Text)

42import Data.Text (Text)

41import qualified Data.Text as Text

43import qualified Data.Text as Text

44+import qualified Data.Text.Lazy as TL

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

42import Data.Vector (Vector)

46import Data.Vector (Vector)

43import qualified Data.Vector as Vector

47import qualified Data.Vector as Vector

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

54--

58--

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

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

56-- See @'validateToJSONWithPatternChecker'@.

60-- See @'validateToJSONWithPatternChecker'@.

61+--

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

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

64+validatePrettyToJSON = renderValidationErrors validateToJSON

65+

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

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

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

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

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

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

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

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

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

62--

72--

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

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

74+-- 'renderValidationErrors'.

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

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

65validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

76validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON

66 where

77 where

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

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

80+-- | Pretty print validation errors

81+-- together with actual JSON and Swagger Schema

82+-- (using 'encodePretty').

83+--

84+-- >>> import Data.Aeson as Aeson

85+-- >>> import Data.Foldable (traverse_)

86+-- >>> import GHC.Generics

87+-- >>> data Phone = Phone { value :: String } deriving (Generic)

88+-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)

89+-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]

90+-- >>> instance ToSchema Phone

91+-- >>> instance ToSchema Person

92+-- >>> let person = Person { name = "John", phone = Phone "123456" }

93+-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person

94+-- Validation against the schema fails:

95+-- * property "phone" is required, but not found in "{\"name\":\"John\"}"

96+-- <BLANKLINE>

97+-- JSON value:

98+-- {

99+-- "name": "John"

100+-- }

101+-- <BLANKLINE>

102+-- Swagger Schema:

103+-- {

104+-- "required": [

105+-- "name",

106+-- "phone"

107+-- ],

108+-- "type": "object",

109+-- "properties": {

110+-- "phone": {

111+-- "$ref": "#/definitions/Phone"

112+-- },

113+-- "name": {

114+-- "type": "string"

115+-- }

116+-- }

117+-- }

118+-- <BLANKLINE>

119+-- Swagger Description Context:

120+-- {

121+-- "Phone": {

122+-- "required": [

123+-- "value"

124+-- ],

125+-- "type": "object",

126+-- "properties": {

127+-- "value": {

128+-- "type": "string"

129+-- }

130+-- }

131+-- }

132+-- }

133+-- <BLANKLINE>

134+renderValidationErrors

135+ :: forall a. (ToJSON a, ToSchema a)

136+ => (a -> [ValidationError]) -> a -> Maybe String

137+renderValidationErrors f x =

138+ case f x of

139+ [] -> Nothing

140+ errors -> Just $ unlines

141+ [ "Validation against the schema fails:"

142+ , unlines (map (" * " ++) errors)

143+ , "JSON value:"

144+ , ppJSONString (toJSON x)

145+ , ""

146+ , "Swagger Schema:"

147+ , ppJSONString (toJSON schema_)

148+ , ""

149+ , "Swagger Description Context:"

150+ , ppJSONString (toJSON refs_)

151+ ]

152+ where

153+ ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty

154+ (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

155+

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

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

70--

157--

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

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

@@ -382,45 +469,43 @@ inferParamSchemaTypes sch = concat

382

469

383validateSchemaType :: Value -> Validation Schema ()

470validateSchemaType :: Value -> Validation Schema ()

384validateSchemaType value = withSchema $ \sch ->

471validateSchemaType value = withSchema $ \sch ->

385− case sch ^. type_ of

472+ case (sch ^. type_, value) of

386− Just explicitType -> validateSchemaTypeAs explicitType value

387− Nothing ->

388− case inferSchemaTypes sch of

389− [t] -> validateSchemaTypeAs t value

390− [] -> invalid $ "unable to infer type for schema, please provide type explicitly"

391− ts -> invalid $ "unable to infer type for schema, possible candidates: " ++ intercalate ", " (map show ts)

392−

393−validateSchemaTypeAs

394− :: SwaggerType 'SwaggerKindSchema -> Value -> Validation Schema ()

395−validateSchemaTypeAs t value =

396− case (t, value) of

397− (SwaggerNull, Null) -> valid

473+ (Just SwaggerNull, Null) -> valid

398− (SwaggerBoolean, Bool _) -> valid

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

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

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

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

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

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

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

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

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

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

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

480+ (Nothing, Null) -> valid

481+ (Nothing, Bool _) -> valid

482+ -- Number by default

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

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

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

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

404− _ -> invalid $ "expected JSON value of type " ++ show t

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

405

488

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

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

407validateParamSchemaType value = withSchema $ \sch ->

490validateParamSchemaType value = withSchema $ \sch ->

408− case sch ^. type_ of

491+ case (sch ^. type_, value) of

409− Just explicitType -> validateParamSchemaTypeAs explicitType value

410− Nothing ->

411− case inferParamSchemaTypes sch of

412− [t] -> validateParamSchemaTypeAs t value

413− [] -> invalid $ "unable to infer type for schema, please provide type explicitly"

414− ts -> invalid $ "unable to infer type for schema, possible candidates: " ++ intercalate ", " (map show ts)

415−

416−validateParamSchemaTypeAs

417− :: SwaggerType t -> Value -> Validation (ParamSchema t) ()

418−validateParamSchemaTypeAs t value =

419− case (t, value) of

420− (SwaggerBoolean, Bool _) -> valid

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

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

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

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

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

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

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

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

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

497+ (Nothing, Bool _) -> valid

498+ -- Number by default

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

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

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

425− _ -> invalid $ "expected JSON value of type " ++ show t

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

426−

503+

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

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

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

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

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

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

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

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

src/Data/Swagger/Lens.hs+6

@@ -96,6 +96,12 @@ instance At Responses where at n = responses . at n

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

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

99+type instance Index SecurityDefinitions = Text

100+type instance IxValue SecurityDefinitions = SecurityScheme

101+

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

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

104+

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

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

100

106

101-- HasType instances

107-- HasType instances

src/Data/Swagger/Operation.hs+3−2

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

46import Data.Swagger.Schema

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

49+import qualified Data.HashSet.InsOrd as InsOrdHS

50-- $setup

51-- $setup

51-- >>> import Data.Aeson

52-- >>> import Data.Aeson

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

111-- list of tags.

112-- list of tags.

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

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

113applyTagsFor ops ts swag = swag

114applyTagsFor ops ts swag = swag

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

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

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

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

116

117

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

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

118-- necessary schema definitions.

119-- necessary schema definitions.

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

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE OverloadedLabels #-}

5+{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE UndecidableInstances #-}

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

9+-- |

10+-- Module: Data.Swagger.Optics

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

12+-- Stability: experimental

13+--

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

15+-- library.

16+--

17+-- >>> import Data.Aeson

18+-- >>> import Optics.Core

19+-- >>> :set -XOverloadedLabels

20+--

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

22+--

23+-- >>> :{

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

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

26+-- & #paths .~

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

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

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

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

31+-- :}

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

33+--

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

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

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

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

38+--

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

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

41+-- >>> :{

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

43+-- & #type ?~ SwaggerBoolean

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

45+-- :}

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

47+--

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

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

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

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

52+-- @#paramSchema@:

53+--

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

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

56+--

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

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

59+--

60+-- >>> :{

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

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

63+-- :}

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

65+--

66+module Data.Swagger.Optics () where

67+

68+import Data.Aeson (Value)

69+import Data.Scientific (Scientific)

70+import Data.Swagger.Internal

71+import Data.Text (Text)

72+import Optics.Core

73+import Optics.TH

74+

75+-- Lenses

76+

77+makeFieldLabels ''Swagger

78+makeFieldLabels ''Host

79+makeFieldLabels ''Info

80+makeFieldLabels ''Contact

81+makeFieldLabels ''License

82+makeFieldLabels ''PathItem

83+makeFieldLabels ''Tag

84+makeFieldLabels ''Operation

85+makeFieldLabels ''Param

86+makeFieldLabels ''ParamOtherSchema

87+makeFieldLabels ''Header

88+makeFieldLabels ''Schema

89+makeFieldLabels ''NamedSchema

90+makeFieldLabels ''ParamSchema

91+makeFieldLabels ''Xml

92+makeFieldLabels ''Responses

93+makeFieldLabels ''Response

94+makeFieldLabels ''SecurityScheme

95+makeFieldLabels ''ApiKeyParams

96+makeFieldLabels ''OAuth2Params

97+makeFieldLabels ''ExternalDocs

98+

99+-- Prisms

100+

101+makePrismLabels ''ParamAnySchema

102+makePrismLabels ''SecuritySchemeType

103+makePrismLabels ''Referenced

104+

105+-- SwaggerItems prisms

106+

107+instance

108+ ( a ~ [Referenced Schema]

109+ , b ~ [Referenced Schema]

110+ ) => LabelOptic "_SwaggerItemsArray"

111+ A_Review

112+ (SwaggerItems 'SwaggerKindSchema)

113+ (SwaggerItems 'SwaggerKindSchema)

114+ a

115+ b where

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

117+ {-# INLINE labelOptic #-}

118+

119+instance

120+ ( a ~ Referenced Schema

121+ , b ~ Referenced Schema

122+ ) => LabelOptic "_SwaggerItemsObject"

123+ A_Review

124+ (SwaggerItems 'SwaggerKindSchema)

125+ (SwaggerItems 'SwaggerKindSchema)

126+ a

127+ b where

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

129+ {-# INLINE labelOptic #-}

130+

131+instance

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

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

134+ ) => LabelOptic "_SwaggerItemsPrimitive"

135+ A_Review

136+ (SwaggerItems t)

137+ (SwaggerItems t)

138+ a

139+ b where

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

141+ {-# INLINE labelOptic #-}

142+

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

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

145+

146+type instance Index Responses = HttpStatusCode

147+type instance Index Operation = HttpStatusCode

148+

149+type instance IxValue Responses = Referenced Response

150+type instance IxValue Operation = Referenced Response

151+

152+instance Ixed Responses where

153+ ix n = #responses % ix n

154+ {-# INLINE ix #-}

155+instance At Responses where

156+ at n = #responses % at n

157+ {-# INLINE at #-}

158+

159+instance Ixed Operation where

160+ ix n = #responses % ix n

161+ {-# INLINE ix #-}

162+instance At Operation where

163+ at n = #responses % at n

164+ {-# INLINE at #-}

165+

166+-- #paramSchema

167+

168+instance

169+ ( a ~ ParamSchema 'SwaggerKindSchema

170+ , b ~ ParamSchema 'SwaggerKindSchema

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

172+ labelOptic = #schema % #paramSchema

173+ {-# INLINE labelOptic #-}

174+

175+-- #type

176+

177+instance

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

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

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

181+ labelOptic = #paramSchema % #type

182+ {-# INLINE labelOptic #-}

183+

184+instance

185+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

186+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

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

188+ labelOptic = #paramSchema % #type

189+ {-# INLINE labelOptic #-}

190+

191+instance

192+ ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)

193+ , b ~ Maybe (SwaggerType 'SwaggerKindSchema)

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

195+ labelOptic = #paramSchema % #type

196+ {-# INLINE labelOptic #-}

197+

198+instance

199+ ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

200+ , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)

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

202+ labelOptic = #paramSchema % #type

203+ {-# INLINE labelOptic #-}

204+

205+-- #default

206+

207+instance

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

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

210+ labelOptic = #paramSchema % #default

211+ {-# INLINE labelOptic #-}

212+

213+instance

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

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

216+ labelOptic = #paramSchema % #default

217+ {-# INLINE labelOptic #-}

218+

219+instance

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

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

222+ labelOptic = #paramSchema % #default

223+ {-# INLINE labelOptic #-}

224+

225+instance

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

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

228+ labelOptic = #paramSchema % #default

229+ {-# INLINE labelOptic #-}

230+

231+-- #format

232+

233+instance

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

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

236+ labelOptic = #paramSchema % #format

237+ {-# INLINE labelOptic #-}

238+

239+instance

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

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

242+ labelOptic = #paramSchema % #format

243+ {-# INLINE labelOptic #-}

244+

245+instance

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

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

248+ labelOptic = #paramSchema % #format

249+ {-# INLINE labelOptic #-}

250+

251+instance

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

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

254+ labelOptic = #paramSchema % #format

255+ {-# INLINE labelOptic #-}

256+

257+-- #items

258+

259+instance

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

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

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

263+ labelOptic = #paramSchema % #items

264+ {-# INLINE labelOptic #-}

265+

266+instance

267+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

268+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

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

270+ labelOptic = #paramSchema % #items

271+ {-# INLINE labelOptic #-}

272+

273+instance

274+ ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)

275+ , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)

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

277+ labelOptic = #paramSchema % #items

278+ {-# INLINE labelOptic #-}

279+

280+instance

281+ ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

282+ , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)

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

284+ labelOptic = #paramSchema % #items

285+ {-# INLINE labelOptic #-}

286+

287+-- #maximum

288+

289+instance

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

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

292+ labelOptic = #paramSchema % #maximum

293+ {-# INLINE labelOptic #-}

294+

295+instance

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

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

298+ labelOptic = #paramSchema % #maximum

299+ {-# INLINE labelOptic #-}

300+

301+instance

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

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

304+ labelOptic = #paramSchema % #maximum

305+ {-# INLINE labelOptic #-}

306+

307+instance

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

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

310+ labelOptic = #paramSchema % #maximum

311+ {-# INLINE labelOptic #-}

312+

313+-- #exclusiveMaximum

314+

315+instance

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

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

318+ labelOptic = #paramSchema % #exclusiveMaximum

319+ {-# INLINE labelOptic #-}

320+

321+instance

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

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

324+ labelOptic = #paramSchema % #exclusiveMaximum

325+ {-# INLINE labelOptic #-}

326+

327+instance

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

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

330+ labelOptic = #paramSchema % #exclusiveMaximum

331+ {-# INLINE labelOptic #-}

332+

333+instance

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

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

336+ labelOptic = #paramSchema % #exclusiveMaximum

337+ {-# INLINE labelOptic #-}

338+

339+-- #minimum

340+

341+instance

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

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

344+ labelOptic = #paramSchema % #minimum

345+ {-# INLINE labelOptic #-}

346+

347+instance

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

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

350+ labelOptic = #paramSchema % #minimum

351+ {-# INLINE labelOptic #-}

352+

353+instance

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

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

356+ labelOptic = #paramSchema % #minimum

357+ {-# INLINE labelOptic #-}

358+

359+instance

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

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

362+ labelOptic = #paramSchema % #minimum

363+ {-# INLINE labelOptic #-}

364+

365+-- #exclusiveMinimum

366+

367+instance

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

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

370+ labelOptic = #paramSchema % #exclusiveMinimum

371+ {-# INLINE labelOptic #-}

372+

373+instance

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

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

376+ labelOptic = #paramSchema % #exclusiveMinimum

377+ {-# INLINE labelOptic #-}

378+

379+instance

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

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

382+ labelOptic = #paramSchema % #exclusiveMinimum

383+ {-# INLINE labelOptic #-}

384+

385+instance

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

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

388+ labelOptic = #paramSchema % #exclusiveMinimum

389+ {-# INLINE labelOptic #-}

390+

391+-- #maxLength

392+

393+instance

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

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

396+ labelOptic = #paramSchema % #maxLength

397+ {-# INLINE labelOptic #-}

398+

399+instance

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

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

402+ labelOptic = #paramSchema % #maxLength

403+ {-# INLINE labelOptic #-}

404+

405+instance

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

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

408+ labelOptic = #paramSchema % #maxLength

409+ {-# INLINE labelOptic #-}

410+

411+instance

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

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

414+ labelOptic = #paramSchema % #maxLength

415+ {-# INLINE labelOptic #-}

416+

417+-- #minLength

418+

419+instance

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

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

422+ labelOptic = #paramSchema % #minLength

423+ {-# INLINE labelOptic #-}

424+

425+instance

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

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

428+ labelOptic = #paramSchema % #minLength

429+ {-# INLINE labelOptic #-}

430+

431+instance

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

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

434+ labelOptic = #paramSchema % #minLength

435+ {-# INLINE labelOptic #-}

436+

437+instance

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

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

440+ labelOptic = #paramSchema % #minLength

441+ {-# INLINE labelOptic #-}

442+

443+-- #pattern

444+

445+instance

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

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

448+ labelOptic = #paramSchema % #pattern

449+ {-# INLINE labelOptic #-}

450+

451+instance

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

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

454+ labelOptic = #paramSchema % #pattern

455+ {-# INLINE labelOptic #-}

456+

457+instance

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

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

460+ labelOptic = #paramSchema % #pattern

461+ {-# INLINE labelOptic #-}

462+

463+instance

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

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

466+ labelOptic = #paramSchema % #pattern

467+ {-# INLINE labelOptic #-}

468+

469+-- #maxItems

470+

471+instance

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

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

474+ labelOptic = #paramSchema % #maxItems

475+ {-# INLINE labelOptic #-}

476+

477+instance

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

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

480+ labelOptic = #paramSchema % #maxItems

481+ {-# INLINE labelOptic #-}

482+

483+instance

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

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

486+ labelOptic = #paramSchema % #maxItems

487+ {-# INLINE labelOptic #-}

488+

489+instance

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

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

492+ labelOptic = #paramSchema % #maxItems

493+ {-# INLINE labelOptic #-}

494+

495+-- #minItems

496+

497+instance

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

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

500+ labelOptic = #paramSchema % #minItems

501+ {-# INLINE labelOptic #-}

502+

503+instance

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

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

506+ labelOptic = #paramSchema % #minItems

507+ {-# INLINE labelOptic #-}

508+

509+instance

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

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

512+ labelOptic = #paramSchema % #minItems

513+ {-# INLINE labelOptic #-}

514+

515+instance

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

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

518+ labelOptic = #paramSchema % #minItems

519+ {-# INLINE labelOptic #-}

520+

521+-- #uniqueItems

522+

523+instance

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

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

526+ labelOptic = #paramSchema % #uniqueItems

527+ {-# INLINE labelOptic #-}

528+

529+instance

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

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

532+ labelOptic = #paramSchema % #uniqueItems

533+ {-# INLINE labelOptic #-}

534+

535+instance

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

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

538+ labelOptic = #paramSchema % #uniqueItems

539+ {-# INLINE labelOptic #-}

540+

541+instance

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

543+ ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where

544+ labelOptic = #paramSchema % #uniqueItems

545+ {-# INLINE labelOptic #-}

546+

547+-- #enum

548+

549+instance

550+ ( a ~ Maybe [Value], b ~ Maybe [Value]

551+ ) => LabelOptic "enum" A_Lens Header Header a b where

552+ labelOptic = #paramSchema % #enum

553+ {-# INLINE labelOptic #-}

554+

555+instance

556+ ( a ~ Maybe [Value], b ~ Maybe [Value]

557+ ) => LabelOptic "enum" A_Lens Schema Schema a b where

558+ labelOptic = #paramSchema % #enum

559+ {-# INLINE labelOptic #-}

560+

561+instance

562+ ( a ~ Maybe [Value], b ~ Maybe [Value]

563+ ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where

564+ labelOptic = #paramSchema % #enum

565+ {-# INLINE labelOptic #-}

566+

567+instance

568+ ( a ~ Maybe [Value], b ~ Maybe [Value]

569+ ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where

570+ labelOptic = #paramSchema % #enum

571+ {-# INLINE labelOptic #-}

572+

573+-- #multipleOf

574+

575+instance

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

577+ ) => LabelOptic "multipleOf" A_Lens Header Header a b where

578+ labelOptic = #paramSchema % #multipleOf

579+ {-# INLINE labelOptic #-}

580+

581+instance

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

583+ ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where

584+ labelOptic = #paramSchema % #multipleOf

585+ {-# INLINE labelOptic #-}

586+

587+instance

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

589+ ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where

590+ labelOptic = #paramSchema % #multipleOf

591+ {-# INLINE labelOptic #-}

592+

593+instance

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

595+ ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where

596+ labelOptic = #paramSchema % #multipleOf

597+ {-# INLINE labelOptic #-}

src/Data/Swagger/Schema/Generator.hs+4−1

@@ -26,6 +26,8 @@ import Test.QuickCheck (arbitrary)

26import Test.QuickCheck.Gen

27import Test.QuickCheck.Property

29+-- | Note: 'schemaGen' may 'error', if schema type is not specified,

30+-- and cannot be inferred.

29schemaGen :: Definitions Schema -> Schema -> Gen Value

31schemaGen :: Definitions Schema -> Schema -> Gen Value

30schemaGen _ schema

32schemaGen _ schema

31 | Just cases <- schema ^. paramSchema . enum_ = elements cases

33 | Just cases <- schema ^. paramSchema . enum_ = elements cases

@@ -34,7 +36,8 @@ schemaGen defns schema =

34 Nothing ->

36 Nothing ->

35 case inferSchemaTypes schema of

37 case inferSchemaTypes schema of

36 [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

38 [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)

39+ -- Gen is not MonadFail

37− _ -> fail "unable to infer schema type"

40+ _ -> error "unable to infer schema type"

38 Just SwaggerBoolean -> Bool <$> elements [True, False]

41 Just SwaggerBoolean -> Bool <$> elements [True, False]

39 Just SwaggerNull -> pure Null

42 Just SwaggerNull -> pure Null

40 Just SwaggerNumber

43 Just SwaggerNumber

src/Data/Swagger/Schema/Validation.hs+2

@@ -19,8 +19,10 @@ module Data.Swagger.Schema.Validation (

19 ValidationError,

21 -- ** Using 'ToJSON' and 'ToSchema'

22+ validatePrettyToJSON,

22 validateToJSON,

23 validateToJSON,

23 validateToJSONWithPatternChecker,

24 validateToJSONWithPatternChecker,

25+ renderValidationErrors,

25 -- ** Using 'Value' and 'Schema'

27 -- ** Using 'Value' and 'Schema'

26 validateJSON,

28 validateJSON,

stack.yaml+6−4

@@ -1,7 +1,9 @@

1−resolver: lts-12.10

1+resolver: lts-14.3

2packages:

3- '.'

4extra-deps:

5−- aeson-1.4.2.0

5+- optics-core-0.2

6−- base-compat-batteries-0.10.4

6+- optics-th-0.2

7−- contravariant-1.5

7+- optics-extra-0.2

8+- indexed-profunctors-0.1

9+- insert-ordered-containers-0.2.3

swagger2.cabal+17−14

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

1cabal-version: >=1.10

2name: swagger2

3−version: 2.3.1.1

3+version: 2.5

5synopsis: Swagger 2.0 data model

6category: Web, Swagger

@@ -24,12 +24,11 @@ extra-source-files:

24 , examples/*.hs

25 , include/overlapping-compat.h

26tested-with:

27− GHC ==7.8.4

28− || ==7.10.3

29− || ==8.0.2

27+ GHC ==8.0.2

30 || ==8.2.2

28 || ==8.2.2

31 || ==8.4.4

29 || ==8.4.4

32− || ==8.6.4

30+ || ==8.6.5

31+ || ==8.8.1

34custom-setup

33custom-setup

35 setup-depends:

34 setup-depends:

@@ -43,6 +42,7 @@ library

43 Data.Swagger.Declare

42 Data.Swagger.Declare

44 Data.Swagger.Lens

43 Data.Swagger.Lens

45 Data.Swagger.Operation

44 Data.Swagger.Operation

45+ Data.Swagger.Optics

46 Data.Swagger.ParamSchema

47 Data.Swagger.Schema

48 Data.Swagger.Schema.Generator

@@ -60,11 +60,12 @@ library

61 -- GHC boot libraries

62 build-depends:

63− base >=4.7 && <4.13

63+ base >=4.9 && <4.14

64+ , aeson-pretty >=0.8.7 && <0.9

64 , bytestring >=0.10.4.0 && <0.11

65 , bytestring >=0.10.4.0 && <0.11

65 , containers >=0.5.5.1 && <0.7

66 , containers >=0.5.5.1 && <0.7

66− , template-haskell >=2.9.0.0 && <2.15

67+ , template-haskell >=2.9.0.0 && <2.16

67− , time >=1.4.2 && <1.9

68+ , time >=1.4.2 && <1.10

68 , transformers >=0.3.0.0 && <0.6

69 , transformers >=0.3.0.0 && <0.6

70 build-depends:

71 build-depends:

@@ -73,16 +74,18 @@ library

74 -- other dependencies

75 -- other dependencies

75 build-depends:

76 build-depends:

76− base-compat-batteries >=0.10.4 && <0.11

77+ base-compat-batteries >=0.10.4 && <0.12

77 , aeson >=1.4.2.0 && <1.5

78 , aeson >=1.4.2.0 && <1.5

78 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

79 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint

79 , cookie >=0.4.3 && <0.5

80 , cookie >=0.4.3 && <0.5

80− , generics-sop >=0.3.2.0 && <0.5

81+ , generics-sop >=0.3.2.0 && <0.6

81− , hashable >=1.2.7.0 && <1.3

82+ , hashable >=1.2.7.0 && <1.4

82 , http-media >=0.7.1.2 && <0.9

83 , http-media >=0.7.1.2 && <0.9

83− , insert-ordered-containers >=0.2.1.0 && <0.3

84+ , insert-ordered-containers >=0.2.3 && <0.3

84− , lens >=4.16.1 && <4.18

85+ , lens >=4.16.1 && <4.19

85− , network >=2.6.3.5 && <3.1

86+ , network >=2.6.3.5 && <3.2

87+ , optics-core >=0.2 && <0.3

88+ , optics-th >=0.2 && <0.3

86 , scientific >=0.3.6.2 && <0.4

89 , scientific >=0.3.6.2 && <0.4

87 , transformers-compat >=0.3 && <0.7

90 , transformers-compat >=0.3 && <0.7

88 , unordered-containers >=0.2.9.0 && <0.3

91 , unordered-containers >=0.2.9.0 && <0.3

test/Data/Swagger/CommonTestTypes.hs+29−2

@@ -18,8 +18,6 @@ import qualified Data.Text as Text

18import GHC.Generics

20import Data.Swagger

21−import Data.Swagger.Declare

22−import Data.Swagger.Internal (SwaggerKind (..))

24-- ========================================================================

22-- ========================================================================

25-- Unit type

23-- Unit type

@@ -650,3 +648,32 @@ singleMaybeFieldSchemaJSON = [aesonQQ|

650 }

648 }

651}

649}

652|]

650|]

651+

652+

653+-- ========================================================================

654+-- TimeOfDay

655+-- ========================================================================

656+data TimeOfDay

657+ = Int

658+ | Pico

659+ deriving (Generic)

660+instance ToSchema TimeOfDay

661+instance ToParamSchema TimeOfDay

662+

663+

664+timeOfDaySchemaJSON :: Value

665+timeOfDaySchemaJSON = [aesonQQ|

666+{

667+ "example": "12:33:15",

668+ "type": "string",

669+ "format": "hh:MM:ss"

670+}

671+|]

672+

673+timeOfDayParamSchemaJSON :: Value

674+timeOfDayParamSchemaJSON = [aesonQQ|

675+{

676+ "type": "string",

677+ "format": "hh:MM:ss"

678+}

679+|]

test/Data/Swagger/ParamSchemaSpec.hs+6−1

@@ -3,9 +3,10 @@

3{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE TemplateHaskell #-}

5{-# LANGUAGE QuasiQuotes #-}

6+{-# LANGUAGE OverloadedStrings #-}

6module Data.Swagger.ParamSchemaSpec where

7module Data.Swagger.ParamSchemaSpec where

8−import Data.Aeson (Value)

9+import Data.Aeson

9import Data.Aeson.QQ.Simple

10import Data.Aeson.QQ.Simple

10import Data.Char

11import Data.Char

11import Data.Proxy

12import Data.Proxy

@@ -17,6 +18,9 @@ import Data.Swagger.Internal (SwaggerKind(..))

17import Data.Swagger.CommonTestTypes

18import Data.Swagger.CommonTestTypes

18import SpecCommon

19import SpecCommon

19import Test.Hspec

20import Test.Hspec

21+import Data.Time.LocalTime

22+

23+import qualified Data.HashMap.Strict as HM

21checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

25checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec

22checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

26checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js

@@ -30,6 +34,7 @@ spec = do

30 context "Unary records" $ do

34 context "Unary records" $ do

31 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

35 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON

32 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

36 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON

37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON

34main :: IO ()

39main :: IO ()

35main = hspec spec

40main = hspec spec

test/Data/Swagger/SchemaSpec.hs+5−6

@@ -8,16 +8,11 @@ import Prelude ()

8import Prelude.Compat

10import Control.Lens ((^.))

11−import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))

11+import Data.Aeson (Value)

12−import Data.Aeson.Types (toJSONKeyText)

13−import Data.Aeson.QQ.Simple

14−import Data.Char

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

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

16import Data.Proxy

13import Data.Proxy

17import Data.Set (Set)

14import Data.Set (Set)

18−import Data.Map (Map)

19import qualified Data.Text as Text

15import qualified Data.Text as Text

20−import GHC.Generics

22import Data.Swagger

17import Data.Swagger

23import Data.Swagger.Declare

18import Data.Swagger.Declare

@@ -26,6 +21,9 @@ import Data.Swagger.CommonTestTypes

26import SpecCommon

21import SpecCommon

27import Test.Hspec

22import Test.Hspec

24+import qualified Data.HashMap.Strict as HM

25+import Data.Time.LocalTime

26+

29checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

27checkToSchema :: ToSchema a => Proxy a -> Value -> Spec

30checkToSchema proxy js = toSchema proxy <=> js

28checkToSchema proxy js = toSchema proxy <=> js

@@ -110,6 +108,7 @@ spec = do

110 context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

108 context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'

111 describe "Bounded Enum key mapping" $ do

109 describe "Bounded Enum key mapping" $ do

112 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

110 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON

111+ context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON

113

112

114main :: IO ()

113main :: IO ()

115main = hspec spec

114main = hspec spec

test/Data/SwaggerSpec.hs+46−5

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

12import Data.Aeson

13import Data.Aeson.QQ.Simple

14import Data.HashMap.Strict (HashMap)

15−import qualified Data.Set as Set

15+import qualified Data.HashSet.InsOrd as InsOrdHS

16import Data.Text (Text)

18import Data.Swagger

@@ -43,6 +43,7 @@ spec = do

43 describe "Parameters Definition Object" $ paramsDefinitionExample <=> paramsDefinitionExampleJSON

44 describe "Responses Definition Object" $ responsesDefinitionExample <=> responsesDefinitionExampleJSON

45 describe "Security Definitions Object" $ securityDefinitionsExample <=> securityDefinitionsExampleJSON

46+ describe "OAuth2 Security Definitions with merged Scope" $ oAuth2SecurityDefinitionsExample <=> oAuth2SecurityDefinitionsExampleJSON

46 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

47 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON

47 describe "Swagger Object" $ do

48 describe "Swagger Object" $ do

48 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

49 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON

@@ -127,7 +128,7 @@ licenseExampleJSON = [aesonQQ|

127

128

128operationExample :: Operation

129operationExample :: Operation

129operationExample = mempty

130operationExample = mempty

130− & tags .~ Set.fromList ["pet"]

131+ & tags .~ InsOrdHS.fromList ["pet"]

131 & summary ?~ "Updates a pet in the store with form data"

132 & summary ?~ "Updates a pet in the store with form data"

132 & description ?~ ""

133 & description ?~ ""

133 & operationId ?~ "updatePetWithForm"

134 & operationId ?~ "updatePetWithForm"

@@ -459,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|

459-- Responses Definition object

460-- Responses Definition object

460-- =======================================================================

461-- =======================================================================

461

462

462−securityDefinitionsExample :: HashMap Text SecurityScheme

463+securityDefinitionsExample :: SecurityDefinitions

463−securityDefinitionsExample =

464+securityDefinitionsExample = SecurityDefinitions

464 [ ("api_key", SecurityScheme

465 [ ("api_key", SecurityScheme

465 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)

466 , _securitySchemeDescription = Nothing })

467 , _securitySchemeDescription = Nothing })

@@ -492,6 +493,46 @@ securityDefinitionsExampleJSON = [aesonQQ|

492}

493}

493|]

494|]

494

495

496+oAuth2SecurityDefinitionsReadExample :: SecurityDefinitions

497+oAuth2SecurityDefinitionsReadExample = SecurityDefinitions

498+ [ ("petstore_auth", SecurityScheme

499+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params

500+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"

501+ , _oauth2Scopes =

502+ [ ("read:pets", "read your pets") ] } )

503+ , _securitySchemeDescription = Nothing })

504+ ]

505+

506+oAuth2SecurityDefinitionsWriteExample :: SecurityDefinitions

507+oAuth2SecurityDefinitionsWriteExample = SecurityDefinitions

508+ [ ("petstore_auth", SecurityScheme

509+ { _securitySchemeType = SecuritySchemeOAuth2 (OAuth2Params

510+ { _oauth2Flow = OAuth2Implicit "http://swagger.io/api/oauth/dialog"

511+ , _oauth2Scopes =

512+ [ ("write:pets", "modify pets in your account") ] } )

513+ , _securitySchemeDescription = Nothing })

514+ ]

515+

516+oAuth2SecurityDefinitionsExample :: SecurityDefinitions

517+oAuth2SecurityDefinitionsExample =

518+ oAuth2SecurityDefinitionsWriteExample <>

519+ oAuth2SecurityDefinitionsReadExample

520+

521+oAuth2SecurityDefinitionsExampleJSON :: Value

522+oAuth2SecurityDefinitionsExampleJSON = [aesonQQ|

523+{

524+ "petstore_auth": {

525+ "type": "oauth2",

526+ "authorizationUrl": "http://swagger.io/api/oauth/dialog",

527+ "flow": "implicit",

528+ "scopes": {

529+ "write:pets": "modify pets in your account",

530+ "read:pets": "read your pets"

531+ }

532+ }

533+}

534+|]

535+

495-- =======================================================================

536-- =======================================================================

496-- Swagger object

537-- Swagger object

497-- =======================================================================

538-- =======================================================================

@@ -531,7 +572,7 @@ swaggerExample = mempty

531 & schema .~ ParamOther (mempty

572 & schema .~ ParamOther (mempty

532 & in_ .~ ParamPath

573 & in_ .~ ParamPath

533 & type_ ?~ SwaggerString ) ]

574 & type_ ?~ SwaggerString ) ]

534− & tags .~ Set.fromList [ "todo" ] ))

575+ & tags .~ InsOrdHS.fromList [ "todo" ] ))

535

576

536swaggerExampleJSON :: Value

577swaggerExampleJSON :: Value

537swaggerExampleJSON = [aesonQQ|

578swaggerExampleJSON = [aesonQQ|