git.iko.soy/typeable/swagger2
on master help sign in
16 files changed+900−88
since splitsnapshots
unifiedsplit
.ghci+1 .travis.yml+49−54 CHANGELOG.md+13 src/Data/Swagger.hs+6−1 src/Data/Swagger/Internal.hs+36−1 src/Data/Swagger/Internal/ParamSchema.hs+3 src/Data/Swagger/Internal/Schema/Validation.hs+92−6 src/Data/Swagger/Lens.hs+6 src/Data/Swagger/Optics.hs+597 src/Data/Swagger/Schema/Validation.hs+2 stack.yaml+6−6 swagger2.cabal+11−9 test/Data/Swagger/CommonTestTypes.hs+29−2 test/Data/Swagger/ParamSchemaSpec.hs+1−1 test/Data/Swagger/SchemaSpec.hs+5−6 test/Data/SwaggerSpec.hs+43−2
.ghci+1
@@ -1 +1,2 @@
11:set -itest -isrc -optP-include -optP.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/autogen/cabal_macros.h -optP-I -optPinclude
2+:set -hide-package base-compat-0.10.4
.travis.yml+49−54
@@ -4,7 +4,7 @@
44#
55# For more information, see https://github.com/haskell-CI/haskell-ci
66#
7−# version: 0.3.20190429
7+# version: 0.5.20191020
88#
99language: c
1010dist: xenial
@@ -31,30 +31,25 @@ matrix:
3131 include:
3232 - compiler: ghc-8.8.1
3333 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
34− env: GHCHEAD=true
3534 - compiler: ghc-8.6.5
36− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}
35+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
3736 - compiler: ghc-8.4.4
38− 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"]}}
3938 - compiler: ghc-8.2.2
40− 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"]}}
4140 - compiler: ghc-8.0.2
42− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}
43− - compiler: ghc-7.10.3
44− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-2.4"]}}
45− - compiler: ghc-7.8.4
46− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-2.4"]}}
47− allow_failures:
48− - compiler: ghc-8.8.1
41+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
4942before_install:
5043 - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
44+ - WITHCOMPILER="-w $HC"
45+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
5146 - HCPKG="$HC-pkg"
5247 - unset CC
5348 - CABAL=/opt/ghc/bin/cabal
5449 - CABALHOME=$HOME/.cabal
5550 - export PATH="$CABALHOME/bin:$PATH"
5651 - TOP=$(pwd)
57− - 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))')"
5853 - echo $HCNUMVER
5954 - CABAL="$CABAL -vnormal+nowrap+markoutput"
6055 - set -o pipefail
@@ -81,35 +76,35 @@ install:
8176 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
8277 - TEST=--enable-tests
8378 - BENCH=--enable-benchmarks
84− - GHCHEAD=${GHCHEAD-false}
79+ - HEADHACKAGE=false
8580 - rm -f $CABALHOME/config
8681 - |
87− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
88− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
89− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
90− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
91− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
92− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
93− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
94− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
95− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
96− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
97− echo "install-dirs user" >> $CABALHOME/config
98− echo " prefix: $CABALHOME" >> $CABALHOME/config
99− echo "repository hackage.haskell.org" >> $CABALHOME/config
100− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
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
101105 - |
102− if $GHCHEAD; then
103− echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config
104−
105− echo "repository head.hackage" >> $CABALHOME/config
106− echo " url: http://head.hackage.haskell.org/" >> $CABALHOME/config
107− echo " secure: True" >> $CABALHOME/config
108− echo " root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740" >> $CABALHOME/config
109− echo " 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb" >> $CABALHOME/config
110− echo " 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e" >> $CABALHOME/config
111− echo " key-threshold: 3" >> $CABALHOME/config
112− fi
106+ echo "program-default-options" >> $CABALHOME/config
107+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
113108 - cat $CABALHOME/config
114109 - rm -fv cabal.project cabal.project.local cabal.project.freeze
115110 - travis_retry ${CABAL} v2-update -v
@@ -117,18 +112,17 @@ install:
117112 - rm -rf cabal.project cabal.project.local cabal.project.freeze
118113 - touch cabal.project
119114 - |
120− echo 'packages: "."' >> cabal.project
115+ echo "packages: ." >> cabal.project
121116 - |
122− echo "write-ghc-environment-files: always" >> cabal.project
123117 - "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"
124118 - cat cabal.project || true
125119 - cat cabal.project.local || true
126120 - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
127− - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output
121+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
128122 - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
129123 - rm cabal.project.freeze
130− - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
131− - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output
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
132126script:
133127 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
134128 # Packaging...
@@ -136,32 +130,33 @@ script:
136130 # Unpacking...
137131 - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
138132 - cd ${DISTDIR} || false
139− - 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.]*')"
140136 # Generate cabal.project
141137 - rm -rf cabal.project cabal.project.local cabal.project.freeze
142138 - touch cabal.project
143139 - |
144− echo 'packages: "swagger2-*/*.cabal"' >> cabal.project
140+ echo "packages: ${PKGDIR_swagger2}" >> cabal.project
145141 - |
146− echo "write-ghc-environment-files: always" >> cabal.project
147142 - "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"
148143 - cat cabal.project || true
149144 - cat cabal.project.local || true
150145 # Building...
151146 # this builds all libraries and executables (without tests/benchmarks)
152− - ${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
153148 # Building with tests and benchmarks...
154149 # build & run tests, build benchmarks
155− - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output
150+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
156151 # Testing...
157− - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output
152+ - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
158153 # cabal check...
159− - (cd swagger2-* && ${CABAL} -vnormal check)
154+ - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)
160155 # haddock...
161− - 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
162157 # Building without installed constraints for packages in global-db...
163158 - rm -f cabal.project.local
164− - ${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
165160
166−# 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"])
167162# EOF
CHANGELOG.md+13
@@ -1,3 +1,16 @@
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+
1142.4
215---
316
src/Data/Swagger.hs+6−1
@@ -31,6 +31,7 @@ module Data.Swagger (
3131
3232 -- * Re-exports
3333 module Data.Swagger.Lens,
34+ module Data.Swagger.Optics,
3435 module Data.Swagger.Operation,
3536 module Data.Swagger.ParamSchema,
3637 module Data.Swagger.Schema,
@@ -88,6 +89,7 @@ module Data.Swagger (
8889 SecurityScheme(..),
8990 SecuritySchemeType(..),
9091 SecurityRequirement(..),
92+ SecurityDefinitions(..),
9193
9294 -- *** API key
9395 ApiKeyParams(..),
@@ -112,6 +114,7 @@ module Data.Swagger (
112114) where
113115
114116import Data.Swagger.Lens
117+import Data.Swagger.Optics ()
115118import Data.Swagger.Operation
116119import Data.Swagger.ParamSchema
117120import Data.Swagger.Schema
@@ -175,6 +178,8 @@ import Data.Swagger.Internal
175178
176179-- $lens
177180--
181+-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics".
182+--
178183-- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
179184-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
180185-- make it fairly simple to construct/modify any part of the specification:
@@ -275,7 +280,7 @@ import Data.Swagger.Internal
275280-- >>> encode $ toSchema (Proxy :: Proxy Person)
276281-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"integer\"}},\"type\":\"object\"}"
277282--
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
279284-- schema for basic enums like
280285--
281286-- >>> data SampleEnum = ChoiceOne | ChoiceTwo deriving Generic
src/Data/Swagger/Internal.hs+36−1
@@ -117,7 +117,7 @@ data Swagger = Swagger
117117 , _swaggerResponses :: Definitions Response
118118
119119 -- | Security scheme definitions that can be used across the specification.
120− , _swaggerSecurityDefinitions :: Definitions SecurityScheme
120+ , _swaggerSecurityDefinitions :: SecurityDefinitions
121121
122122 -- | A declaration of which security schemes are applied for the API as a whole.
123123 -- The list of values describes alternative security schemes that can be used
@@ -755,6 +755,22 @@ data SecurityScheme = SecurityScheme
755755 , _securitySchemeDescription :: Maybe Text
756756 } deriving (Eq, Show, Generic, Data, Typeable)
757757
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+
758774-- | Lists the required security schemes to execute this operation.
759775-- The object can have multiple security schemes declared in it which are all required
760776-- (that is, there is a logical AND between the schemes).
@@ -904,6 +920,17 @@ instance Monoid Example where
904920 mempty = genericMempty
905921 mappend = (<>)
906922
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+
907934-- =======================================================================
908935-- SwaggerMonoid helper instances
909936-- =======================================================================
@@ -918,6 +945,7 @@ instance SwaggerMonoid Responses
918945instance SwaggerMonoid Response
919946instance SwaggerMonoid ExternalDocs
920947instance SwaggerMonoid Operation
948+instance SwaggerMonoid SecurityDefinitions
921949instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
922950
923951instance SwaggerMonoid MimeList
@@ -1118,6 +1146,9 @@ instance ToJSON PathItem where
11181146instance ToJSON Example where
11191147 toJSON = toJSON . Map.mapKeys show . getExample
11201148
1149+instance ToJSON SecurityDefinitions where
1150+ toJSON (SecurityDefinitions sd) = toJSON sd
1151+
11211152instance ToJSON Reference where
11221153 toJSON (Reference ref) = object [ "$ref" .= ref ]
11231154
@@ -1279,6 +1310,9 @@ instance FromJSON Operation where
12791310instance FromJSON PathItem where
12801311 parseJSON = sopSwaggerGenericParseJSON
12811312
1313+instance FromJSON SecurityDefinitions where
1314+ parseJSON js = SecurityDefinitions <$> parseJSON js
1315+
12821316instance FromJSON Reference where
12831317 parseJSON (Object o) = Reference <$> o .: "$ref"
12841318 parseJSON _ = empty
@@ -1390,3 +1424,4 @@ instance AesonDefaultValue (SwaggerType a)
13901424instance AesonDefaultValue MimeList where defaultValue = Just mempty
13911425instance AesonDefaultValue Info
13921426instance AesonDefaultValue ParamLocation
1427+instance AesonDefaultValue SecurityDefinitions where defaultValue = Just $ SecurityDefinitions mempty
src/Data/Swagger/Internal/ParamSchema.hs+3
@@ -193,6 +193,9 @@ timeParamSchema fmt = mempty
193193instance ToParamSchema Day where
194194 toParamSchema _ = timeParamSchema "date"
195195
196+-- |
197+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198+-- Just "hh:MM:ss"
196199instance ToParamSchema TimeOfDay where
197200 toParamSchema _ = timeParamSchema "hh:MM:ss"
198201
src/Data/Swagger/Internal/Schema/Validation.hs+92−6
@@ -22,23 +22,27 @@
2222-- Validate JSON values with Swagger Schema.
2323module Data.Swagger.Internal.Schema.Validation where
2424
25+import Prelude ()
26+import Prelude.Compat
27+
2528import Control.Applicative
2629import Control.Lens
2730import Control.Monad (when)
2831
2932import Data.Aeson hiding (Result)
33+import Data.Aeson.Encode.Pretty (encodePretty)
3034import Data.Foldable (for_, sequenceA_,
3135 traverse_)
3236import Data.HashMap.Strict (HashMap)
3337import qualified Data.HashMap.Strict as HashMap
3438import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
3539import qualified "unordered-containers" Data.HashSet as HashSet
36−import Data.List (intercalate)
37−import Data.Monoid
3840import Data.Proxy
3941import Data.Scientific (Scientific, isInteger)
4042import Data.Text (Text)
4143import qualified Data.Text as Text
44+import qualified Data.Text.Lazy as TL
45+import qualified Data.Text.Lazy.Encoding as TL
4246import Data.Vector (Vector)
4347import qualified Data.Vector as Vector
4448
@@ -54,18 +58,101 @@ import Data.Swagger.Lens
5458--
5559-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
5660-- 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.
5767validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
5868validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
5969
6070-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
6171-- This can be used with QuickCheck to ensure those instances are coherent.
6272--
63−-- For validation without patterns see @'validateToJSON'@.
73+-- For validation without patterns see @'validateToJSON'@. See also:
74+-- 'renderValidationErrors'.
6475validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError]
6576validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON
6677 where
6778 (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
6879
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+
69156-- | Validate JSON @'Value'@ against Swagger @'Schema'@.
70157--
71158-- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []
@@ -397,7 +484,7 @@ validateSchemaType value = withSchema $ \sch ->
397484 (Nothing, String s) -> sub_ paramSchema (validateString s)
398485 (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
399486 (Nothing, Object o) -> validateObject o
400− param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param
487+ bad -> invalid $ "expected JSON value of type " ++ showType bad
401488
402489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
403490validateParamSchemaType value = withSchema $ \sch ->
@@ -412,8 +499,7 @@ validateParamSchemaType value = withSchema $ \sch ->
412499 (Nothing, Number n) -> validateNumber n
413500 (Nothing, String s) -> validateString s
414501 (Nothing, Array xs) -> validateArray xs
415− (t, _) -> invalid $ "expected JSON value of type " ++ show t
416− param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param
502+ bad -> invalid $ "expected JSON value of type " ++ showType bad
417503
418504showType :: (Maybe (SwaggerType t), Value) -> String
419505showType (Just type_, _) = show type_
src/Data/Swagger/Lens.hs+6
@@ -96,6 +96,12 @@ instance At Responses where at n = responses . at n
9696instance Ixed Operation where ix n = responses . ix n
9797instance At Operation where at n = responses . at n
9898
99+type instance Index SecurityDefinitions = Text
100+type instance IxValue SecurityDefinitions = SecurityScheme
101+
102+instance Ixed SecurityDefinitions where ix n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). ix n
103+instance At SecurityDefinitions where at n = (coerced :: Lens' SecurityDefinitions (Definitions SecurityScheme)). at n
104+
99105instance HasParamSchema NamedSchema (ParamSchema 'SwaggerKindSchema) where paramSchema = schema.paramSchema
100106
101107-- HasType instances
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/Validation.hs+2
@@ -19,8 +19,10 @@ module Data.Swagger.Schema.Validation (
1919 ValidationError,
2020
2121 -- ** Using 'ToJSON' and 'ToSchema'
22+ validatePrettyToJSON,
2223 validateToJSON,
2324 validateToJSONWithPatternChecker,
25+ renderValidationErrors,
2426
2527 -- ** Using 'Value' and 'Schema'
2628 validateJSON,
stack.yaml+6−6
@@ -1,9 +1,9 @@
1−resolver: lts-13.23
1+resolver: lts-14.3
22packages:
33- '.'
44extra-deps:
5−- aeson-1.4.2.0
6−- base-compat-batteries-0.10.4
7−- contravariant-1.5
8−- insert-ordered-containers-0.2.2
9−#- base-compat-0.10.4
5+- optics-core-0.2
6+- optics-th-0.2
7+- optics-extra-0.2
8+- indexed-profunctors-0.1
9+- insert-ordered-containers-0.2.3
swagger2.cabal+11−9
@@ -1,6 +1,6 @@
11cabal-version: >=1.10
22name: swagger2
3−version: 2.4
3+version: 2.5
44
55synopsis: Swagger 2.0 data model
66category: Web, Swagger
@@ -24,9 +24,7 @@ extra-source-files:
2424 , examples/*.hs
2525 , include/overlapping-compat.h
2626tested-with:
27− GHC ==7.8.4
28− || ==7.10.3
29− || ==8.0.2
27+ GHC ==8.0.2
3028 || ==8.2.2
3129 || ==8.4.4
3230 || ==8.6.5
@@ -44,6 +42,7 @@ library
4442 Data.Swagger.Declare
4543 Data.Swagger.Lens
4644 Data.Swagger.Operation
45+ Data.Swagger.Optics
4746 Data.Swagger.ParamSchema
4847 Data.Swagger.Schema
4948 Data.Swagger.Schema.Generator
@@ -61,10 +60,11 @@ library
6160
6261 -- GHC boot libraries
6362 build-depends:
64− base >=4.7 && <4.13
63+ base >=4.9 && <4.14
64+ , aeson-pretty >=0.8.7 && <0.9
6565 , bytestring >=0.10.4.0 && <0.11
6666 , containers >=0.5.5.1 && <0.7
67− , template-haskell >=2.9.0.0 && <2.15
67+ , template-haskell >=2.9.0.0 && <2.16
6868 , time >=1.4.2 && <1.10
6969 , transformers >=0.3.0.0 && <0.6
7070
@@ -74,16 +74,18 @@ library
7474
7575 -- other dependencies
7676 build-depends:
77− base-compat-batteries >=0.10.4 && <0.11
77+ base-compat-batteries >=0.10.4 && <0.12
7878 , aeson >=1.4.2.0 && <1.5
7979 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
8080 , cookie >=0.4.3 && <0.5
8181 , generics-sop >=0.3.2.0 && <0.6
8282 , hashable >=1.2.7.0 && <1.4
8383 , http-media >=0.7.1.2 && <0.9
84− , insert-ordered-containers >=0.2.2 && <0.3
85− , lens >=4.16.1 && <4.18
84+ , insert-ordered-containers >=0.2.3 && <0.3
85+ , lens >=4.16.1 && <4.19
8686 , network >=2.6.3.5 && <3.2
87+ , optics-core >=0.2 && <0.3
88+ , optics-th >=0.2 && <0.3
8789 , scientific >=0.3.6.2 && <0.4
8890 , transformers-compat >=0.3 && <0.7
8991 , 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
1818import GHC.Generics
1919
2020import Data.Swagger
21−import Data.Swagger.Declare
22−import Data.Swagger.Internal (SwaggerKind (..))
2321
2422-- ========================================================================
2523-- Unit type
@@ -650,3 +648,32 @@ singleMaybeFieldSchemaJSON = [aesonQQ|
650648 }
651649}
652650|]
651+
652+
653+-- ========================================================================
654+-- TimeOfDay
655+-- ========================================================================
656+data TimeOfDay
657+ = Int
658+ | Pico
659+ deriving (Generic)
660+instance ToSchema TimeOfDay
661+instance ToParamSchema TimeOfDay
662+
663+
664+timeOfDaySchemaJSON :: Value
665+timeOfDaySchemaJSON = [aesonQQ|
666+{
667+ "example": "12:33:15",
668+ "type": "string",
669+ "format": "hh:MM:ss"
670+}
671+|]
672+
673+timeOfDayParamSchemaJSON :: Value
674+timeOfDayParamSchemaJSON = [aesonQQ|
675+{
676+ "type": "string",
677+ "format": "hh:MM:ss"
678+}
679+|]
test/Data/Swagger/ParamSchemaSpec.hs+1−1
@@ -34,7 +34,7 @@ spec = do
3434 context "Unary records" $ do
3535 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
3636 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37− context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy TimeOfDay) (Object (HM.fromList [("format",String "hh:MM:ss"),("type",String "string")]))
37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
3838
3939main :: IO ()
4040main = hspec spec
test/Data/Swagger/SchemaSpec.hs+5−6
@@ -8,16 +8,11 @@ import Prelude ()
88import Prelude.Compat
99
1010import Control.Lens ((^.))
11−import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))
12−import Data.Aeson.Types (toJSONKeyText)
13−import Data.Aeson.QQ.Simple
14−import Data.Char
11+import Data.Aeson (Value)
1512import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
1613import Data.Proxy
1714import Data.Set (Set)
18−import Data.Map (Map)
1915import qualified Data.Text as Text
20−import GHC.Generics
2116
2217import Data.Swagger
2318import Data.Swagger.Declare
@@ -26,6 +21,9 @@ import Data.Swagger.CommonTestTypes
2621import SpecCommon
2722import Test.Hspec
2823
24+import qualified Data.HashMap.Strict as HM
25+import Data.Time.LocalTime
26+
2927checkToSchema :: ToSchema a => Proxy a -> Value -> Spec
3028checkToSchema proxy js = toSchema proxy <=> js
3129
@@ -110,6 +108,7 @@ spec = do
110108 context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
111109 describe "Bounded Enum key mapping" $ do
112110 context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
111+ context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON
113112
114113main :: IO ()
115114main = hspec spec
test/Data/SwaggerSpec.hs+43−2
@@ -43,6 +43,7 @@ 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
4647 describe "Composition Schema Example" $ compositionSchemaExample <=> compositionSchemaExampleJSON
4748 describe "Swagger Object" $ do
4849 context "Todo Example" $ swaggerExample <=> swaggerExampleJSON
@@ -459,8 +460,8 @@ responsesDefinitionExampleJSON = [aesonQQ|
459460-- Responses Definition object
460461-- =======================================================================
461462
462−securityDefinitionsExample :: HashMap Text SecurityScheme
463−securityDefinitionsExample =
463+securityDefinitionsExample :: SecurityDefinitions
464+securityDefinitionsExample = SecurityDefinitions
464465 [ ("api_key", SecurityScheme
465466 { _securitySchemeType = SecuritySchemeApiKey (ApiKeyParams "api_key" ApiKeyHeader)
466467 , _securitySchemeDescription = Nothing })
@@ -492,6 +493,46 @@ securityDefinitionsExampleJSON = [aesonQQ|
492493}
493494|]
494495
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+
495536-- =======================================================================
496537-- Swagger object
497538-- =======================================================================