git.iko.soy/typeable/swagger2
on master help sign in
22 files changed+1011−128
since splitsnapshots
unifiedsplit
.ghci+1 .travis.yml+55−42 CHANGELOG.md+26 cabal.project+2 examples/hackage.hs+1−1 src/Data/Swagger.hs+6−1 src/Data/Swagger/Internal.hs+47−6 src/Data/Swagger/Internal/AesonUtils.hs+14 src/Data/Swagger/Internal/ParamSchema.hs+6 src/Data/Swagger/Internal/Schema.hs+5−1 src/Data/Swagger/Internal/Schema/Validation.hs+127−42 src/Data/Swagger/Lens.hs+6 src/Data/Swagger/Operation.hs+3−2 src/Data/Swagger/Optics.hs+597 src/Data/Swagger/Schema/Generator.hs+4−1 src/Data/Swagger/Schema/Validation.hs+2 stack.yaml+6−4 swagger2.cabal+17−14 test/Data/Swagger/CommonTestTypes.hs+29−2 test/Data/Swagger/ParamSchemaSpec.hs+6−1 test/Data/Swagger/SchemaSpec.hs+5−6 test/Data/SwaggerSpec.hs+46−5
.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+55−42
@@ -4,7 +4,7 @@
44#
55# For more information, see https://github.com/haskell-CI/haskell-ci
66#
7−# version: 0.3.20190413
7+# version: 0.5.20191020
88#
99language: c
1010dist: xenial
@@ -29,27 +29,27 @@ before_cache:
2929 - rm -rfv $CABALHOME/packages/head.hackage
3030matrix:
3131 include:
32− - compiler: ghc-8.6.4
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.4","cabal-install-2.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
35+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
3436 - 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"]}}
3638 - 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"]}}
3840 - compiler: ghc-8.0.2
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}
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"]}}
41+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
4442before_install:
4543 - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
44+ - WITHCOMPILER="-w $HC"
45+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
4646 - HCPKG="$HC-pkg"
4747 - unset CC
4848 - CABAL=/opt/ghc/bin/cabal
4949 - CABALHOME=$HOME/.cabal
5050 - export PATH="$CABALHOME/bin:$PATH"
5151 - 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))')"
5353 - echo $HCNUMVER
5454 - CABAL="$CABAL -vnormal+nowrap+markoutput"
5555 - set -o pipefail
@@ -76,22 +76,35 @@ install:
7676 - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
7777 - TEST=--enable-tests
7878 - BENCH=--enable-benchmarks
79− - GHCHEAD=${GHCHEAD-false}
79+ - HEADHACKAGE=false
8080 - rm -f $CABALHOME/config
8181 - |
82− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
83− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
84− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
85− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
86− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
87− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
88− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
89− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
90− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
91− echo "install-dirs user" >> $CABALHOME/config
92− echo " prefix: $CABALHOME" >> $CABALHOME/config
93− echo "repository hackage.haskell.org" >> $CABALHOME/config
94− 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
105+ - |
106+ echo "program-default-options" >> $CABALHOME/config
107+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
95108 - cat $CABALHOME/config
96109 - rm -fv cabal.project cabal.project.local cabal.project.freeze
97110 - travis_retry ${CABAL} v2-update -v
@@ -99,18 +112,17 @@ install:
99112 - rm -rf cabal.project cabal.project.local cabal.project.freeze
100113 - touch cabal.project
101114 - |
102− echo 'packages: "."' >> cabal.project
115+ echo "packages: ." >> cabal.project
103116 - |
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"
106118 - cat cabal.project || true
107119 - cat cabal.project.local || true
108120 - 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
110122 - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
111123 - rm cabal.project.freeze
112− - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output
113− - ${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
114126script:
115127 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
116128 # Packaging...
@@ -118,32 +130,33 @@ script:
118130 # Unpacking...
119131 - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
120132 - 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.]*')"
122136 # Generate cabal.project
123137 - rm -rf cabal.project cabal.project.local cabal.project.freeze
124138 - touch cabal.project
125139 - |
126− echo 'packages: "swagger2-*/*.cabal"' >> cabal.project
140+ echo "packages: ${PKGDIR_swagger2}" >> cabal.project
127141 - |
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"
130143 - cat cabal.project || true
131144 - cat cabal.project.local || true
132145 # Building...
133146 # 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
135148 # Building with tests and benchmarks...
136149 # 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
138151 # Testing...
139− - ${CABAL} v2-test -w ${HC} ${TEST} ${BENCH} all | color_cabal_output
152+ - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
140153 # cabal check...
141− - (cd swagger2-* && ${CABAL} -vnormal check)
154+ - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check)
142155 # 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
144157 # Building without installed constraints for packages in global-db...
145158 - 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
147160
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"])
149162# EOF
CHANGELOG.md+26
@@ -1,5 +1,31 @@
1+2.5
2+---
3+
4+Highlights:
5+- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));
6+- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));
7+- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));
8+
9+Fixes and minor changes:
10+- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));
11+- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));
12+- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));
13+
14+2.4
15+---
16+
17+- Allow hashable-1.3, semigroups-0.19, network-3.1, time-1.9, generics-sop-0.5
18+- Tags aren't sorted
19+ (see [#165](https://github.com/GetShopTV/swagger2/issues/165))
20+- Schema type is optional
21+ (see [#138](https://github.com/GetShopTV/swagger2/issues/138), [#164](https://github.com/GetShopTV/swagger2/pull/164))
22+- Take concrete 'Proxy' as argument
23+ (see [#180](https://github.com/GetShopTV/swagger2/pull/180))
24+- GHC-8.8 preparations
25+
1262.3.1.1
227-------
28+
329- Allow `network-3.0`
430
5312.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
2727 usernameSchema <- declareSchemaRef (Proxy :: Proxy Username)
2828 useridSchema <- declareSchemaRef (Proxy :: Proxy Int)
2929 return $ NamedSchema (Just "UserSummary") $ mempty
30− & type_ .~ SwaggerObject
30+ & type_ ?~ SwaggerObject
3131 & properties .~
3232 [ ("summaryUsername", usernameSchema )
3333 , ("summaryUserid" , useridSchema )
src/Data/Swagger.hs+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+47−6
@@ -29,13 +29,14 @@ import Control.Applicative
2929import Data.Aeson
3030import qualified Data.Aeson.Types as JSON
3131import Data.Data (Data(..), Typeable, mkConstr, mkDataType, Fixity(..), Constr, DataType, constrIndex)
32+import Data.Hashable (Hashable)
3233import qualified Data.HashMap.Strict as HashMap
34+import Data.HashSet.InsOrd (InsOrdHashSet)
3335import Data.Map (Map)
3436import qualified Data.Map as Map
3537import Data.Monoid (Monoid (..))
3638import Data.Semigroup.Compat (Semigroup (..))
3739import Data.Scientific (Scientific)
38−import Data.Set (Set)
3940import Data.String (IsString(..))
4041import Data.Text (Text)
4142import qualified Data.Text as Text
@@ -116,7 +117,7 @@ data Swagger = Swagger
116117 , _swaggerResponses :: Definitions Response
117118
118119 -- | Security scheme definitions that can be used across the specification.
119− , _swaggerSecurityDefinitions :: Definitions SecurityScheme
120+ , _swaggerSecurityDefinitions :: SecurityDefinitions
120121
121122 -- | A declaration of which security schemes are applied for the API as a whole.
122123 -- The list of values describes alternative security schemes that can be used
@@ -129,7 +130,7 @@ data Swagger = Swagger
129130 -- Not all tags that are used by the Operation Object must be declared.
130131 -- The tags that are not declared may be organized randomly or based on the tools' logic.
131132 -- Each tag name in the list MUST be unique.
132− , _swaggerTags :: Set Tag
133+ , _swaggerTags :: InsOrdHashSet Tag
133134
134135 -- | Additional external documentation.
135136 , _swaggerExternalDocs :: Maybe ExternalDocs
@@ -251,7 +252,7 @@ data PathItem = PathItem
251252data Operation = Operation
252253 { -- | A list of tags for API documentation control.
253254 -- Tags can be used for logical grouping of operations by resources or any other qualifier.
254− _operationTags :: Set TagName
255+ _operationTags :: InsOrdHashSet TagName
255256
256257 -- | A short summary of what the operation does.
257258 -- For maximum readability in the swagger-ui, this field SHOULD be less than 120 characters.
@@ -610,7 +611,7 @@ data ParamSchema (t :: SwaggerKind *) = ParamSchema
610611 , _paramSchemaMultipleOf :: Maybe Scientific
611612 } deriving (Eq, Show, Generic, Typeable)
612613
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)
614615
615616data Xml = Xml
616617 { -- | Replaces the name of the element/attribute used for the described schema property.
@@ -754,6 +755,22 @@ data SecurityScheme = SecurityScheme
754755 , _securitySchemeDescription :: Maybe Text
755756 } deriving (Eq, Show, Generic, Data, Typeable)
756757
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+
757774-- | Lists the required security schemes to execute this operation.
758775-- The object can have multiple security schemes declared in it which are all required
759776-- (that is, there is a logical AND between the schemes).
@@ -778,6 +795,8 @@ data Tag = Tag
778795 , _tagExternalDocs :: Maybe ExternalDocs
779796 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
780797
798+instance Hashable Tag
799+
781800instance IsString Tag where
782801 fromString s = Tag (fromString s) Nothing Nothing
783802
@@ -791,6 +810,8 @@ data ExternalDocs = ExternalDocs
791810 , _externalDocsUrl :: URL
792811 } deriving (Eq, Ord, Show, Generic, Data, Typeable)
793812
813+instance Hashable ExternalDocs
814+
794815-- | A simple object to allow referencing other definitions in the specification.
795816-- It can be used to reference parameters and responses that are defined at the top level for reuse.
796817newtype Reference = Reference { getReference :: Text }
@@ -804,7 +825,7 @@ data Referenced a
804825instance IsString a => IsString (Referenced a) where
805826 fromString = Inline . fromString
806827
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)
808829
809830data AdditionalProperties
810831 = AdditionalPropertiesAllowed Bool
@@ -899,6 +920,17 @@ instance Monoid Example where
899920 mempty = genericMempty
900921 mappend = (<>)
901922
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+
902934-- =======================================================================
903935-- SwaggerMonoid helper instances
904936-- =======================================================================
@@ -913,6 +945,8 @@ instance SwaggerMonoid Responses
913945instance SwaggerMonoid Response
914946instance SwaggerMonoid ExternalDocs
915947instance SwaggerMonoid Operation
948+instance SwaggerMonoid SecurityDefinitions
949+instance (Eq a, Hashable a) => SwaggerMonoid (InsOrdHashSet a)
916950
917951instance SwaggerMonoid MimeList
918952deriving instance SwaggerMonoid URL
@@ -1112,6 +1146,9 @@ instance ToJSON PathItem where
11121146instance ToJSON Example where
11131147 toJSON = toJSON . Map.mapKeys show . getExample
11141148
1149+instance ToJSON SecurityDefinitions where
1150+ toJSON (SecurityDefinitions sd) = toJSON sd
1151+
11151152instance ToJSON Reference where
11161153 toJSON (Reference ref) = object [ "$ref" .= ref ]
11171154
@@ -1273,6 +1310,9 @@ instance FromJSON Operation where
12731310instance FromJSON PathItem where
12741311 parseJSON = sopSwaggerGenericParseJSON
12751312
1313+instance FromJSON SecurityDefinitions where
1314+ parseJSON js = SecurityDefinitions <$> parseJSON js
1315+
12761316instance FromJSON Reference where
12771317 parseJSON (Object o) = Reference <$> o .: "$ref"
12781318 parseJSON _ = empty
@@ -1384,3 +1424,4 @@ instance AesonDefaultValue (SwaggerType a)
13841424instance AesonDefaultValue MimeList where defaultValue = Just mempty
13851425instance AesonDefaultValue Info
13861426instance 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
4444import qualified Data.HashMap.Strict as HM
4545import qualified Data.Set as Set
4646import qualified Data.HashMap.Strict.InsOrd as InsOrd
47+import qualified Data.HashSet.InsOrd as InsOrdHS
4748
4849#if MIN_VERSION_aeson(0,10,0)
4950import Data.Aeson (Encoding, pairs, (.=), Series)
@@ -85,6 +86,7 @@ instance AesonDefaultValue Text where defaultValue = Nothing
8586instance AesonDefaultValue (Maybe a) where defaultValue = Just Nothing
8687instance AesonDefaultValue [a] where defaultValue = Just []
8788instance AesonDefaultValue (Set.Set a) where defaultValue = Just Set.empty
89+instance AesonDefaultValue (InsOrdHS.InsOrdHashSet k) where defaultValue = Just InsOrdHS.empty
8890instance AesonDefaultValue (InsOrd.InsOrdHashMap k v) where defaultValue = Just InsOrd.empty
8991
9092-------------------------------------------------------------------------------
@@ -144,7 +146,11 @@ sopSwaggerGenericToJSON'
144146 -> DatatypeInfo '[xs]
145147 -> POP Maybe '[xs]
146148 -> [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
147152sopSwaggerGenericToJSON' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
153+#endif
148154 sopSwaggerGenericToJSON'' opts fields fieldsInfo defs
149155sopSwaggerGenericToJSON' _ _ _ _ = error "sopSwaggerGenericToJSON: unsupported type"
150156
@@ -220,7 +226,11 @@ sopSwaggerGenericParseJSON'
220226 -> DatatypeInfo '[xs]
221227 -> POP Maybe '[xs]
222228 -> 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
223232sopSwaggerGenericParseJSON' opts obj (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
233+#endif
224234 SOP . Z <$> sopSwaggerGenericParseJSON'' opts obj fieldsInfo defs
225235sopSwaggerGenericParseJSON' _ _ _ _ = error "sopSwaggerGenericParseJSON: unsupported type"
226236
@@ -292,7 +302,11 @@ sopSwaggerGenericToEncoding'
292302 -> DatatypeInfo '[xs]
293303 -> POP Maybe '[xs]
294304 -> 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
295308sopSwaggerGenericToEncoding' opts (SOP (Z fields)) (ADT _ _ (Record _ fieldsInfo :* Nil)) (POP (defs :* Nil)) =
309+#endif
296310 sopSwaggerGenericToEncoding'' opts fields fieldsInfo defs
297311sopSwaggerGenericToEncoding' _ _ _ _ = error "sopSwaggerGenericToEncoding: unsupported type"
298312
src/Data/Swagger/Internal/ParamSchema.hs+6
@@ -193,6 +193,12 @@ timeParamSchema fmt = mempty
193193instance ToParamSchema Day where
194194 toParamSchema _ = timeParamSchema "date"
195195
196+-- |
197+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format
198+-- Just "hh:MM:ss"
199+instance ToParamSchema TimeOfDay where
200+ toParamSchema _ = timeParamSchema "hh:MM:ss"
201+
196202-- |
197203-- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format
198204-- Just "yyyy-mm-ddThh:MM:ss"
src/Data/Swagger/Internal/Schema.hs+5−1
@@ -147,6 +147,10 @@ class ToSchema a where
147147 Proxy a -> Declare (Definitions Schema) NamedSchema
148148 declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
149149
150+instance ToSchema TimeOfDay where
151+ declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
152+ & example ?~ toJSON (TimeOfDay 12 33 15)
153+
150154-- | Convert a type into a schema and declare all used schema definitions.
151155declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
152156declareSchema = fmap _namedSchemaSchema . declareNamedSchema
@@ -335,7 +339,7 @@ sketchSchema = sketch . toJSON
335339
336340 go Null = mempty & type_ ?~ SwaggerNull
337341 go (Bool _) = mempty & type_ ?~ SwaggerBoolean
338− go (String _) = mempty & type_ ?~ SwaggerString
342+ go (String _) = mempty & type_ ?~ SwaggerString
339343 go (Number _) = mempty & type_ ?~ SwaggerNumber
340344 go (Array xs) = mempty
341345 & type_ ?~ SwaggerArray
src/Data/Swagger/Internal/Schema/Validation.hs+127−42
@@ -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)) == []
@@ -382,45 +469,43 @@ inferParamSchemaTypes sch = concat
382469
383470validateSchemaType :: Value -> Validation Schema ()
384471validateSchemaType value = withSchema $ \sch ->
385− case sch ^. type_ 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
398− (SwaggerBoolean, Bool _) -> valid
399− (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
400− (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
401− (SwaggerString, String s) -> sub_ paramSchema (validateString s)
402− (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
403− (SwaggerObject, Object o) -> validateObject o
404− _ -> invalid $ "expected JSON value of type " ++ show t
472+ case (sch ^. type_, value) of
473+ (Just SwaggerNull, Null) -> valid
474+ (Just SwaggerBoolean, Bool _) -> valid
475+ (Just SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
476+ (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
477+ (Just SwaggerString, String s) -> sub_ paramSchema (validateString s)
478+ (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
479+ (Just SwaggerObject, Object o) -> validateObject o
480+ (Nothing, Null) -> valid
481+ (Nothing, Bool _) -> valid
482+ -- Number by default
483+ (Nothing, Number n) -> sub_ paramSchema (validateNumber n)
484+ (Nothing, String s) -> sub_ paramSchema (validateString s)
485+ (Nothing, Array xs) -> sub_ paramSchema (validateArray xs)
486+ (Nothing, Object o) -> validateObject o
487+ bad -> invalid $ "expected JSON value of type " ++ showType bad
405488
406489validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
407490validateParamSchemaType value = withSchema $ \sch ->
408− case sch ^. type_ 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
421− (SwaggerInteger, Number n) -> validateInteger n
422− (SwaggerNumber, Number n) -> validateNumber n
423− (SwaggerString, String s) -> validateString s
424− (SwaggerArray, Array xs) -> validateArray xs
425− _ -> invalid $ "expected JSON value of type " ++ show t
426−
491+ case (sch ^. type_, value) of
492+ (Just SwaggerBoolean, Bool _) -> valid
493+ (Just SwaggerInteger, Number n) -> validateInteger n
494+ (Just SwaggerNumber, Number n) -> validateNumber n
495+ (Just SwaggerString, String s) -> validateString s
496+ (Just SwaggerArray, Array xs) -> validateArray xs
497+ (Nothing, Bool _) -> valid
498+ -- Number by default
499+ (Nothing, Number n) -> validateNumber n
500+ (Nothing, String s) -> validateString s
501+ (Nothing, Array xs) -> validateArray xs
502+ bad -> invalid $ "expected JSON value of type " ++ showType bad
503+
504+showType :: (Maybe (SwaggerType t), Value) -> String
505+showType (Just type_, _) = show type_
506+showType (Nothing, Null) = "SwaggerNull"
507+showType (Nothing, Bool _) = "SwaggerBoolean"
508+showType (Nothing, Number _) = "SwaggerNumber"
509+showType (Nothing, String _) = "SwaggerString"
510+showType (Nothing, Array _) = "SwaggerArray"
511+showType (Nothing, Object _) = "SwaggerObject"
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/Operation.hs+3−2
@@ -46,6 +46,7 @@ import Data.Swagger.Lens
4646import Data.Swagger.Schema
4747
4848import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
49+import qualified Data.HashSet.InsOrd as InsOrdHS
4950
5051-- $setup
5152-- >>> import Data.Aeson
@@ -111,8 +112,8 @@ applyTags = applyTagsFor allOperations
111112-- list of tags.
112113applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
113114applyTagsFor ops ts swag = swag
114− & ops . tags %~ (<> Set.fromList (map _tagName ts))
115− & tags %~ (<> Set.fromList ts)
115+ & ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
116+ & tags %~ (<> InsOrdHS.fromList ts)
116117
117118-- | Construct a response with @'Schema'@ while declaring all
118119-- necessary schema definitions.
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)
2626import Test.QuickCheck.Gen
2727import Test.QuickCheck.Property
2828
29+-- | Note: 'schemaGen' may 'error', if schema type is not specified,
30+-- and cannot be inferred.
2931schemaGen :: Definitions Schema -> Schema -> Gen Value
3032schemaGen _ schema
3133 | Just cases <- schema ^. paramSchema . enum_ = elements cases
@@ -34,7 +36,8 @@ schemaGen defns schema =
3436 Nothing ->
3537 case inferSchemaTypes schema of
3638 [ inferredType ] -> schemaGen defns (schema & type_ ?~ inferredType)
37− _ -> fail "unable to infer schema type"
39+ -- Gen is not MonadFail
40+ _ -> error "unable to infer schema type"
3841 Just SwaggerBoolean -> Bool <$> elements [True, False]
3942 Just SwaggerNull -> pure Null
4043 Just SwaggerNumber
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−4
@@ -1,7 +1,9 @@
1−resolver: lts-12.10
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
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+17−14
@@ -1,6 +1,6 @@
11cabal-version: >=1.10
22name: swagger2
3−version: 2.3.1.1
3+version: 2.5
44
55synopsis: Swagger 2.0 data model
66category: Web, Swagger
@@ -24,12 +24,11 @@ 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
32− || ==8.6.4
30+ || ==8.6.5
31+ || ==8.8.1
3332
3433custom-setup
3534 setup-depends:
@@ -43,6 +42,7 @@ library
4342 Data.Swagger.Declare
4443 Data.Swagger.Lens
4544 Data.Swagger.Operation
45+ Data.Swagger.Optics
4646 Data.Swagger.ParamSchema
4747 Data.Swagger.Schema
4848 Data.Swagger.Schema.Generator
@@ -60,11 +60,12 @@ library
6060
6161 -- GHC boot libraries
6262 build-depends:
63− base >=4.7 && <4.13
63+ base >=4.9 && <4.14
64+ , aeson-pretty >=0.8.7 && <0.9
6465 , bytestring >=0.10.4.0 && <0.11
6566 , containers >=0.5.5.1 && <0.7
66− , template-haskell >=2.9.0.0 && <2.15
67− , time >=1.4.2 && <1.9
67+ , template-haskell >=2.9.0.0 && <2.16
68+ , time >=1.4.2 && <1.10
6869 , transformers >=0.3.0.0 && <0.6
6970
7071 build-depends:
@@ -73,16 +74,18 @@ library
7374
7475 -- other dependencies
7576 build-depends:
76− base-compat-batteries >=0.10.4 && <0.11
77+ base-compat-batteries >=0.10.4 && <0.12
7778 , aeson >=1.4.2.0 && <1.5
7879 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint
7980 , cookie >=0.4.3 && <0.5
80− , generics-sop >=0.3.2.0 && <0.5
81− , hashable >=1.2.7.0 && <1.3
81+ , generics-sop >=0.3.2.0 && <0.6
82+ , hashable >=1.2.7.0 && <1.4
8283 , http-media >=0.7.1.2 && <0.9
83− , insert-ordered-containers >=0.2.1.0 && <0.3
84− , lens >=4.16.1 && <4.18
85− , network >=2.6.3.5 && <3.1
84+ , insert-ordered-containers >=0.2.3 && <0.3
85+ , lens >=4.16.1 && <4.19
86+ , network >=2.6.3.5 && <3.2
87+ , optics-core >=0.2 && <0.3
88+ , optics-th >=0.2 && <0.3
8689 , scientific >=0.3.6.2 && <0.4
8790 , transformers-compat >=0.3 && <0.7
8891 , 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+6−1
@@ -3,9 +3,10 @@
33{-# LANGUAGE ScopedTypeVariables #-}
44{-# LANGUAGE TemplateHaskell #-}
55{-# LANGUAGE QuasiQuotes #-}
6+{-# LANGUAGE OverloadedStrings #-}
67module Data.Swagger.ParamSchemaSpec where
78
8−import Data.Aeson (Value)
9+import Data.Aeson
910import Data.Aeson.QQ.Simple
1011import Data.Char
1112import Data.Proxy
@@ -17,6 +18,9 @@ import Data.Swagger.Internal (SwaggerKind(..))
1718import Data.Swagger.CommonTestTypes
1819import SpecCommon
1920import Test.Hspec
21+import Data.Time.LocalTime
22+
23+import qualified Data.HashMap.Strict as HM
2024
2125checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec
2226checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js
@@ -30,6 +34,7 @@ spec = do
3034 context "Unary records" $ do
3135 context "Email (unary record)" $ checkToParamSchema (Proxy :: Proxy Email) emailSchemaJSON
3236 context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON
37+ context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON
3338
3439main :: IO ()
3540main = hspec spec
test/Data/Swagger/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+46−5
@@ -12,7 +12,7 @@ import Control.Lens
1212import Data.Aeson
1313import Data.Aeson.QQ.Simple
1414import Data.HashMap.Strict (HashMap)
15−import qualified Data.Set as Set
15+import qualified Data.HashSet.InsOrd as InsOrdHS
1616import Data.Text (Text)
1717
1818import Data.Swagger
@@ -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
@@ -127,7 +128,7 @@ licenseExampleJSON = [aesonQQ|
127128
128129operationExample :: Operation
129130operationExample = mempty
130− & tags .~ Set.fromList ["pet"]
131+ & tags .~ InsOrdHS.fromList ["pet"]
131132 & summary ?~ "Updates a pet in the store with form data"
132133 & description ?~ ""
133134 & operationId ?~ "updatePetWithForm"
@@ -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-- =======================================================================
@@ -531,7 +572,7 @@ swaggerExample = mempty
531572 & schema .~ ParamOther (mempty
532573 & in_ .~ ParamPath
533574 & type_ ?~ SwaggerString ) ]
534− & tags .~ Set.fromList [ "todo" ] ))
575+ & tags .~ InsOrdHS.fromList [ "todo" ] ))
535576
536577swaggerExampleJSON :: Value
537578swaggerExampleJSON = [aesonQQ|