434e26b · typeable/openapi3

git.iko.soy/typeable/openapi3

on master help sign in

Add validateToJSON helper, fix docs, remove encoded value from errors

434e26bNickolay Kudasov11 years ago

src/Data/Swagger/Schema/Validation.hs+47−17

compare with master

unifiedsplit

@@ -7,6 +7,7 @@

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE PackageImports #-}

9{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TemplateHaskell #-}

11{-# LANGUAGE TemplateHaskell #-}

11{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

12-- |

13-- |

@@ -30,19 +31,35 @@ import Data.HashMap.Strict (HashMap)

30import qualified Data.HashMap.Strict as HashMap

31import qualified Data.HashMap.Strict as HashMap

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

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

32import Data.Monoid

33import Data.Monoid

34+import Data.Proxy

33import Data.Scientific (Scientific, isInteger)

35import Data.Scientific (Scientific, isInteger)

34import Data.Text (Text)

36import Data.Text (Text)

35import qualified Data.Text as Text

37import qualified Data.Text as Text

36import Data.Vector (Vector)

38import Data.Vector (Vector)

37import qualified Data.Vector as Vector

39import qualified Data.Vector as Vector

41+import Data.Swagger.Declare

39import Data.Swagger.Internal

42import Data.Swagger.Internal

43+import Data.Swagger.Internal.Schema

40import Data.Swagger.Lens

44import Data.Swagger.Lens

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

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

48+--

49+-- prop> validateToJSON (x :: Int) == []

50+validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [String]

51+validateToJSON x = case runValidation (validateWithSchema js) cfg schema of

52+ Failed xs -> xs

53+ Passed _ -> mempty

54+ where

55+ js = toJSON x

56+ cfg = defaultConfig { configDefinitions = defs }

57+ (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty

59+-- | Validation result type.

43data Result a

60data Result a

44− = Failed [String]

61+ = Failed [String] -- ^ Validation failed with a list of error messages.

45− | Passed a

62+ | Passed a -- ^ Validation passed.

46 deriving (Eq, Show, Functor)

63 deriving (Eq, Show, Functor)

48instance Applicative Result where

65instance Applicative Result where

@@ -62,8 +79,11 @@ instance Monad Result where

62 Passed x >>= f = f x

79 Passed x >>= f = f x

63 Failed xs >>= f = Failed xs

80 Failed xs >>= f = Failed xs

82+-- | Validation configuration.

65data Config = Config

83data Config = Config

84+ { -- | Pattern checker for @'_paramSchemaPattern'@ validation.

66− { configPatternChecker :: Pattern -> Text -> Bool

85+ configPatternChecker :: Pattern -> Text -> Bool

86+ -- | Schema definitions in scope to resolve references.

67 , configDefinitions :: Definitions Schema

87 , configDefinitions :: Definitions Schema

68 }

88 }

@@ -71,7 +91,7 @@ data Config = Config

71--

91--

72-- @

92-- @

73-- defaultConfig = 'Config'

93-- defaultConfig = 'Config'

74−-- { 'configPatternChecker' = \_pattern _str -> True

94+-- { 'configPatternChecker' = \\_pattern _str -> True

75-- , 'configDefinitions' = mempty

95-- , 'configDefinitions' = mempty

76-- }

96-- }

77-- @

97-- @

@@ -81,6 +101,7 @@ defaultConfig = Config

81 , configDefinitions = mempty

101 , configDefinitions = mempty

82 }

102 }

103

104+-- | Value validation.

84newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }

105newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }

85 deriving (Functor)

106 deriving (Functor)

107

@@ -110,24 +131,31 @@ withConfig f = Validation (\c -> runValidation (f c) c)

110withSchema :: (s -> Validation s a) -> Validation s a

131withSchema :: (s -> Validation s a) -> Validation s a

111withSchema f = Validation (\c s -> runValidation (f s) c s)

132withSchema f = Validation (\c s -> runValidation (f s) c s)

112

133

134+-- | Issue an error message.

113invalid :: String -> Validation schema a

135invalid :: String -> Validation schema a

114invalid msg = Validation (\_ _ -> Failed [msg])

136invalid msg = Validation (\_ _ -> Failed [msg])

115

137

138+-- | Validation passed.

116valid :: Validation schema ()

139valid :: Validation schema ()

117valid = pure ()

140valid = pure ()

118

141

142+-- | Validate schema's property given a lens into that property

143+-- and property checker.

119check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

144check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()

120check l g = withSchema $ \schema ->

145check l g = withSchema $ \schema ->

121 case schema ^. l of

146 case schema ^. l of

122 Nothing -> valid

147 Nothing -> valid

123 Just x -> g x

148 Just x -> g x

124

149

150+-- | Validate same value with different schema.

125sub :: t -> Validation t a -> Validation s a

151sub :: t -> Validation t a -> Validation s a

126sub = lmap . const

152sub = lmap . const

127

153

154+-- | Validate same value with a part of the original schema.

128sub_ :: Getting a s a -> Validation a r -> Validation s r

155sub_ :: Getting a s a -> Validation a r -> Validation s r

129sub_ = lmap . view

156sub_ = lmap . view

130

157

158+-- | Validate value against a schema given schema reference and validation function.

131withRef :: Reference -> (Schema -> Validation s a) -> Validation s a

159withRef :: Reference -> (Schema -> Validation s a) -> Validation s a

132withRef (Reference ref) f = withConfig $ \cfg ->

160withRef (Reference ref) f = withConfig $ \cfg ->

133 case HashMap.lookup ref (configDefinitions cfg) of

161 case HashMap.lookup ref (configDefinitions cfg) of

@@ -138,11 +166,13 @@ validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()

138validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)

166validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)

139validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

167validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)

140

168

169+-- | Validate JSON @'Value'@ with Swagger @'Schema'@.

141validateWithSchema :: Value -> Validation Schema ()

170validateWithSchema :: Value -> Validation Schema ()

142validateWithSchema value = do

171validateWithSchema value = do

143 validateSchemaType value

172 validateSchemaType value

144 sub_ paramSchema $ validateEnum value

173 sub_ paramSchema $ validateEnum value

145

174

175+-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.

146validateWithParamSchema :: Value -> Validation (ParamSchema t) ()

176validateWithParamSchema :: Value -> Validation (ParamSchema t) ()

147validateWithParamSchema value = do

177validateWithParamSchema value = do

148 validateParamSchemaType value

178 validateParamSchemaType value

@@ -151,7 +181,7 @@ validateWithParamSchema value = do

151validateInteger :: Scientific -> Validation (ParamSchema t) ()

181validateInteger :: Scientific -> Validation (ParamSchema t) ()

152validateInteger n = do

182validateInteger n = do

153 when (not (isInteger n)) $

183 when (not (isInteger n)) $

154− invalid ("not an integer: " ++ show n)

184+ invalid ("not an integer")

155 validateNumber n

185 validateNumber n

156

186

157validateNumber :: Scientific -> Validation (ParamSchema t) ()

187validateNumber :: Scientific -> Validation (ParamSchema t) ()

@@ -175,16 +205,16 @@ validateString :: Text -> Validation (ParamSchema t) ()

175validateString s = do

205validateString s = do

176 check maxLength $ \n ->

206 check maxLength $ \n ->

177 when (len > fromInteger n) $

207 when (len > fromInteger n) $

178− invalid ("string is too long (length should be <=" ++ show n ++ "): " ++ show s)

208+ invalid ("string is too long (length should be <=" ++ show n ++ ")")

179

209

180 check minLength $ \n ->

210 check minLength $ \n ->

181 when (len < fromInteger n) $

211 when (len < fromInteger n) $

182− invalid ("string is too short (length should be >=" ++ show n ++ "): " ++ show s)

212+ invalid ("string is too short (length should be >=" ++ show n ++ ")")

183

213

184 check pattern $ \regex -> do

214 check pattern $ \regex -> do

185 withConfig $ \cfg -> do

215 withConfig $ \cfg -> do

186 when (not (configPatternChecker cfg regex s)) $

216 when (not (configPatternChecker cfg regex s)) $

187− invalid ("string does not match pattern " ++ show regex ++ ": " ++ show s)

217+ invalid ("string does not match pattern " ++ show regex)

188 where

218 where

189 len = Text.length s

219 len = Text.length s

190

220

@@ -192,23 +222,23 @@ validateArray :: Vector Value -> Validation (ParamSchema t) ()

192validateArray xs = do

222validateArray xs = do

193 check maxItems $ \n ->

223 check maxItems $ \n ->

194 when (len > fromInteger n) $

224 when (len > fromInteger n) $

195− invalid ("array exceeds maximum size (should be <=" ++ show n ++ "): " ++ show (encode xs))

225+ invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")

196

226

197 check minItems $ \n ->

227 check minItems $ \n ->

198 when (len < fromInteger n) $

228 when (len < fromInteger n) $

199− invalid ("array is too short (size should be >=" ++ show n ++ "): " ++ show (encode xs))

229+ invalid ("array is too short (size should be >=" ++ show n ++ ")")

200

230

201 check items $ \case

231 check items $ \case

202 SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs

232 SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs

203 SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs

233 SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs

204 SwaggerItemsArray itemSchemas -> do

234 SwaggerItemsArray itemSchemas -> do

205 when (len /= length itemSchemas) $

235 when (len /= length itemSchemas) $

206− invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ "): " ++ show (encode xs))

236+ invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")

207 sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))

237 sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))

208

238

209 check uniqueItems $ \unique ->

239 check uniqueItems $ \unique ->

210 when (unique && not allUnique) $

240 when (unique && not allUnique) $

211− invalid ("array is expected to contain unique items, but it does not: " ++ show (encode xs))

241+ invalid ("array is expected to contain unique items, but it does not")

212 where

242 where

213 len = Vector.length xs

243 len = Vector.length xs

214 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

244 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))

@@ -219,15 +249,15 @@ validateObject o = withSchema $ \schema ->

219 Just pname -> case fromJSON <$> HashMap.lookup pname o of

249 Just pname -> case fromJSON <$> HashMap.lookup pname o of

220 Just (Success ref) -> validateWithSchemaRef ref (Object o)

250 Just (Success ref) -> validateWithSchemaRef ref (Object o)

221 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

251 Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)

222− Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing: " ++ show (encode o))

252+ Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")

223 Nothing -> do

253 Nothing -> do

224 check maxProperties $ \n ->

254 check maxProperties $ \n ->

225 when (size > n) $

255 when (size > n) $

226− invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ "): " ++ show (encode o))

256+ invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")

227

257

228 check minProperties $ \n ->

258 check minProperties $ \n ->

229 when (size < n) $

259 when (size < n) $

230− invalid ("object size is too small (total number of properties should be >=" ++ show n ++ "): " ++ show (encode o))

260+ invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")

231

261

232 validateRequired

262 validateRequired

233 validateProps

263 validateProps

@@ -264,7 +294,7 @@ validateSchemaType value = withSchema $ \schema ->

264 (SwaggerString, String s) -> sub_ paramSchema (validateString s)

294 (SwaggerString, String s) -> sub_ paramSchema (validateString s)

265 (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

295 (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)

266 (SwaggerObject, Object o) -> validateObject o

296 (SwaggerObject, Object o) -> validateObject o

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

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

268

298

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

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

270validateParamSchemaType value = withSchema $ \schema ->

300validateParamSchemaType value = withSchema $ \schema ->

@@ -274,5 +304,5 @@ validateParamSchemaType value = withSchema $ \schema ->

274 (SwaggerNumber, Number n) -> validateNumber n

304 (SwaggerNumber, Number n) -> validateNumber n

275 (SwaggerString, String s) -> validateString s

305 (SwaggerString, String s) -> validateString s

276 (SwaggerArray, Array xs) -> validateArray xs

306 (SwaggerArray, Array xs) -> validateArray xs

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

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

278

308

test/Data/Swagger/Schema/ValidationSpec.hs+1−4

@@ -37,10 +37,7 @@ import Test.Hspec.QuickCheck

37import Test.QuickCheck

39shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool

40−shouldValidate proxy x = res == Passed ()

40+shouldValidate _ x = validateToJSON x == []

41− where

42− res = runValidation (validateWithSchema (toJSON x)) defaultConfig { configDefinitions = defs } schema

43− (defs, schema) = runDeclare (declareSchema proxy) mempty

45spec :: Spec

42spec :: Spec

46spec = do

43spec = do