@@ -7,6 +7,7 @@
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE PackageImports #-}
99{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
1011{-# LANGUAGE TemplateHaskell #-}
1112{-# LANGUAGE UndecidableInstances #-}
1213-- |
@@ -30,19 +31,35 @@ import Data.HashMap.Strict (HashMap)
3031import qualified Data.HashMap.Strict as HashMap
3132import qualified "unordered-containers" Data.HashSet as HashSet
3233import Data.Monoid
34+import Data.Proxy
3335import Data.Scientific (Scientific, isInteger)
3436import Data.Text (Text)
3537import qualified Data.Text as Text
3638import Data.Vector (Vector)
3739import qualified Data.Vector as Vector
3840
41+import Data.Swagger.Declare
3942import Data.Swagger.Internal
43+import Data.Swagger.Internal.Schema
4044import Data.Swagger.Lens
4145
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
4258
59+-- | Validation result type.
4360data Result a
44− = Failed [String]
45− | Passed a
61+ = Failed [String] -- ^ Validation failed with a list of error messages.
62+ | Passed a -- ^ Validation passed.
4663 deriving (Eq, Show, Functor)
4764
4865instance Applicative Result where
@@ -62,8 +79,11 @@ instance Monad Result where
6279 Passed x >>= f = f x
6380 Failed xs >>= f = Failed xs
6481
82+-- | Validation configuration.
6583data Config = Config
66− { configPatternChecker :: Pattern -> Text -> Bool
84+ { -- | Pattern checker for @'_paramSchemaPattern'@ validation.
85+ configPatternChecker :: Pattern -> Text -> Bool
86+ -- | Schema definitions in scope to resolve references.
6787 , configDefinitions :: Definitions Schema
6888 }
6989
@@ -71,7 +91,7 @@ data Config = Config
7191--
7292-- @
7393-- defaultConfig = 'Config'
74−-- { 'configPatternChecker' = \_pattern _str -> True
94+-- { 'configPatternChecker' = \\_pattern _str -> True
7595-- , 'configDefinitions' = mempty
7696-- }
7797-- @
@@ -81,6 +101,7 @@ defaultConfig = Config
81101 , configDefinitions = mempty
82102 }
83103
104+-- | Value validation.
84105newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
85106 deriving (Functor)
86107
@@ -110,24 +131,31 @@ withConfig f = Validation (\c -> runValidation (f c) c)
110131withSchema :: (s -> Validation s a) -> Validation s a
111132withSchema f = Validation (\c s -> runValidation (f s) c s)
112133
134+-- | Issue an error message.
113135invalid :: String -> Validation schema a
114136invalid msg = Validation (\_ _ -> Failed [msg])
115137
138+-- | Validation passed.
116139valid :: Validation schema ()
117140valid = pure ()
118141
142+-- | Validate schema's property given a lens into that property
143+-- and property checker.
119144check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
120145check l g = withSchema $ \schema ->
121146 case schema ^. l of
122147 Nothing -> valid
123148 Just x -> g x
124149
150+-- | Validate same value with different schema.
125151sub :: t -> Validation t a -> Validation s a
126152sub = lmap . const
127153
154+-- | Validate same value with a part of the original schema.
128155sub_ :: Getting a s a -> Validation a r -> Validation s r
129156sub_ = lmap . view
130157
158+-- | Validate value against a schema given schema reference and validation function.
131159withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
132160withRef (Reference ref) f = withConfig $ \cfg ->
133161 case HashMap.lookup ref (configDefinitions cfg) of
@@ -138,11 +166,13 @@ validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
138166validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)
139167validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
140168
169+-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
141170validateWithSchema :: Value -> Validation Schema ()
142171validateWithSchema value = do
143172 validateSchemaType value
144173 sub_ paramSchema $ validateEnum value
145174
175+-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.
146176validateWithParamSchema :: Value -> Validation (ParamSchema t) ()
147177validateWithParamSchema value = do
148178 validateParamSchemaType value
@@ -151,7 +181,7 @@ validateWithParamSchema value = do
151181validateInteger :: Scientific -> Validation (ParamSchema t) ()
152182validateInteger n = do
153183 when (not (isInteger n)) $
154− invalid ("not an integer: " ++ show n)
184+ invalid ("not an integer")
155185 validateNumber n
156186
157187validateNumber :: Scientific -> Validation (ParamSchema t) ()
@@ -175,16 +205,16 @@ validateString :: Text -> Validation (ParamSchema t) ()
175205validateString s = do
176206 check maxLength $ \n ->
177207 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 ++ ")")
179209
180210 check minLength $ \n ->
181211 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 ++ ")")
183213
184214 check pattern $ \regex -> do
185215 withConfig $ \cfg -> do
186216 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)
188218 where
189219 len = Text.length s
190220
@@ -192,23 +222,23 @@ validateArray :: Vector Value -> Validation (ParamSchema t) ()
192222validateArray xs = do
193223 check maxItems $ \n ->
194224 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 ++ ")")
196226
197227 check minItems $ \n ->
198228 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 ++ ")")
200230
201231 check items $ \case
202232 SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs
203233 SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
204234 SwaggerItemsArray itemSchemas -> do
205235 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) ++ ")")
207237 sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
208238
209239 check uniqueItems $ \unique ->
210240 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")
212242 where
213243 len = Vector.length xs
214244 allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
@@ -219,15 +249,15 @@ validateObject o = withSchema $ \schema ->
219249 Just pname -> case fromJSON <$> HashMap.lookup pname o of
220250 Just (Success ref) -> validateWithSchemaRef ref (Object o)
221251 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")
223253 Nothing -> do
224254 check maxProperties $ \n ->
225255 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 ++ ")")
227257
228258 check minProperties $ \n ->
229259 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 ++ ")")
231261
232262 validateRequired
233263 validateProps
@@ -264,7 +294,7 @@ validateSchemaType value = withSchema $ \schema ->
264294 (SwaggerString, String s) -> sub_ paramSchema (validateString s)
265295 (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
266296 (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
268298
269299validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
270300validateParamSchemaType value = withSchema $ \schema ->
@@ -274,5 +304,5 @@ validateParamSchemaType value = withSchema $ \schema ->
274304 (SwaggerNumber, Number n) -> validateNumber n
275305 (SwaggerString, String s) -> validateString s
276306 (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
278308