@@ -1,324 +1,15 @@
1−{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PackageImports #-}
9−{-# LANGUAGE RankNTypes #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TemplateHaskell #-}
12−{-# LANGUAGE UndecidableInstances #-}
131-- |
14−-- Module: Data.Swagger.Schema.Validate
2+-- Module: Data.Swagger.Schema.Validation
153-- Copyright: (c) 2015 GetShopTV
164-- License: BSD3
175-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
186-- Stability: experimental
197--
208-- Validate JSON values with Swagger Schema.
21−module Data.Swagger.Schema.Validation where
22−
23−import Control.Applicative
24−import Control.Lens
25−import Control.Lens.TH
26−import Control.Monad (when)
27−
28−import Data.Aeson hiding (Result)
29−import Data.Foldable (traverse_, for_, sequenceA_)
30−import Data.HashMap.Strict (HashMap)
31−import qualified Data.HashMap.Strict as HashMap
32−import qualified "unordered-containers" Data.HashSet as HashSet
33−import Data.Monoid
34−import Data.Proxy
35−import Data.Scientific (Scientific, isInteger)
36−import Data.Text (Text)
37−import qualified Data.Text as Text
38−import Data.Vector (Vector)
39−import qualified Data.Vector as Vector
40−
41−import Data.Swagger.Declare
42−import Data.Swagger.Internal
43−import Data.Swagger.Internal.Schema
44−import Data.Swagger.Lens
45−
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−--
51−-- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation.
52−-- See @'validateToJSONWithPatternChecker'@.
53−validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError]
54−validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)
55−
56−-- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker.
57−-- This can be used with QuickCheck to ensure those instances are coherent.
58−--
59−-- For validation without patterns see @'validateToJSON'@.
60−validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) =>
61− (Pattern -> Text -> Bool) -> a -> [ValidationError]
62−validateToJSONWithPatternChecker checker x = case runValidation (validateWithSchema js) cfg schema of
63− Failed xs -> xs
64− Passed _ -> mempty
65− where
66− (defs, schema) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
67− js = toJSON x
68− cfg = defaultConfig
69− { configPatternChecker = checker
70− , configDefinitions = defs }
71−
72−-- | Validation error message.
73−type ValidationError = String
74−
75−-- | Validation result type.
76−data Result a
77− = Failed [ValidationError] -- ^ Validation failed with a list of error messages.
78− | Passed a -- ^ Validation passed.
79− deriving (Eq, Show, Functor)
80−
81−instance Applicative Result where
82− pure = Passed
83− Passed f <*> Passed x = Passed (f x)
84− Failed xs <*> Failed ys = Failed (xs <> ys)
85− Failed xs <*> _ = Failed xs
86− _ <*> Failed ys = Failed ys
87−
88−instance Alternative Result where
89− empty = Failed mempty
90− Passed x <|> _ = Passed x
91− _ <|> y = y
92−
93−instance Monad Result where
94− return = pure
95− Passed x >>= f = f x
96− Failed xs >>= f = Failed xs
97−
98−-- | Validation configuration.
99−data Config = Config
100− { -- | Pattern checker for @'_paramSchemaPattern'@ validation.
101− configPatternChecker :: Pattern -> Text -> Bool
102− -- | Schema definitions in scope to resolve references.
103− , configDefinitions :: Definitions Schema
104− }
105−
106−-- | Default @'Config'@:
107−--
108−-- @
109−-- defaultConfig = 'Config'
110−-- { 'configPatternChecker' = \\_pattern _str -> True
111−-- , 'configDefinitions' = mempty
112−-- }
113−-- @
114−defaultConfig :: Config
115−defaultConfig = Config
116− { configPatternChecker = \_pattern _str -> True
117− , configDefinitions = mempty
118− }
119−
120−-- | Value validation.
121−newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
122− deriving (Functor)
123−
124−instance Applicative (Validation schema) where
125− pure x = Validation (\_ _ -> pure x)
126− Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)
127−
128−instance Alternative (Validation schema) where
129− empty = Validation (\_ _ -> empty)
130− Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)
131−
132−instance Profunctor Validation where
133− dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))
134−
135−instance Choice Validation where
136− left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))
137− right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))
138−
139−instance Monad (Validation s) where
140− return = pure
141− Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)
142− (>>) = (*>)
143−
144−withConfig :: (Config -> Validation s a) -> Validation s a
145−withConfig f = Validation (\c -> runValidation (f c) c)
146−
147−withSchema :: (s -> Validation s a) -> Validation s a
148−withSchema f = Validation (\c s -> runValidation (f s) c s)
149−
150−-- | Issue an error message.
151−invalid :: String -> Validation schema a
152−invalid msg = Validation (\_ _ -> Failed [msg])
153−
154−-- | Validation passed.
155−valid :: Validation schema ()
156−valid = pure ()
157−
158−-- | Validate schema's property given a lens into that property
159−-- and property checker.
160−check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
161−check l g = withSchema $ \schema ->
162− case schema ^. l of
163− Nothing -> valid
164− Just x -> g x
165−
166−-- | Validate same value with different schema.
167−sub :: t -> Validation t a -> Validation s a
168−sub = lmap . const
169−
170−-- | Validate same value with a part of the original schema.
171−sub_ :: Getting a s a -> Validation a r -> Validation s r
172−sub_ = lmap . view
173−
174−-- | Validate value against a schema given schema reference and validation function.
175−withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
176−withRef (Reference ref) f = withConfig $ \cfg ->
177− case HashMap.lookup ref (configDefinitions cfg) of
178− Nothing -> invalid $ "unknown schema " ++ show ref
179− Just s -> f s
180−
181−validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
182−validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)
183−validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
184−
185−-- | Validate JSON @'Value'@ with Swagger @'Schema'@.
186−validateWithSchema :: Value -> Validation Schema ()
187−validateWithSchema value = do
188− validateSchemaType value
189− sub_ paramSchema $ validateEnum value
190−
191−-- | Validate JSON @'Value'@ with Swagger @'ParamSchema'@.
192−validateWithParamSchema :: Value -> Validation (ParamSchema t) ()
193−validateWithParamSchema value = do
194− validateParamSchemaType value
195− validateEnum value
196−
197−validateInteger :: Scientific -> Validation (ParamSchema t) ()
198−validateInteger n = do
199− when (not (isInteger n)) $
200− invalid ("not an integer")
201− validateNumber n
202−
203−validateNumber :: Scientific -> Validation (ParamSchema t) ()
204−validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do
205− let exMax = Just True == schema ^. exclusiveMaximum
206− exMin = Just True == schema ^. exclusiveMinimum
207−
208− check maximum_ $ \m ->
209− when (if exMax then (n >= m) else (n > m)) $
210− invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")
211−
212− check minimum_ $ \m ->
213− when (if exMin then (n <= m) else (n < m)) $
214− invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")
215−
216− check multipleOf $ \k ->
217− when (not (isInteger (n / k))) $
218− invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)
219−
220−validateString :: Text -> Validation (ParamSchema t) ()
221−validateString s = do
222− check maxLength $ \n ->
223− when (len > fromInteger n) $
224− invalid ("string is too long (length should be <=" ++ show n ++ ")")
225−
226− check minLength $ \n ->
227− when (len < fromInteger n) $
228− invalid ("string is too short (length should be >=" ++ show n ++ ")")
229−
230− check pattern $ \regex -> do
231− withConfig $ \cfg -> do
232− when (not (configPatternChecker cfg regex s)) $
233− invalid ("string does not match pattern " ++ show regex)
234− where
235− len = Text.length s
236−
237−validateArray :: Vector Value -> Validation (ParamSchema t) ()
238−validateArray xs = do
239− check maxItems $ \n ->
240− when (len > fromInteger n) $
241− invalid ("array exceeds maximum size (should be <=" ++ show n ++ ")")
242−
243− check minItems $ \n ->
244− when (len < fromInteger n) $
245− invalid ("array is too short (size should be >=" ++ show n ++ ")")
246−
247− check items $ \case
248− SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs
249− SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
250− SwaggerItemsArray itemSchemas -> do
251− when (len /= length itemSchemas) $
252− invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ ")")
253− sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
254−
255− check uniqueItems $ \unique ->
256− when (unique && not allUnique) $
257− invalid ("array is expected to contain unique items, but it does not")
258− where
259− len = Vector.length xs
260− allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
261−
262−validateObject :: HashMap Text Value -> Validation Schema ()
263−validateObject o = withSchema $ \schema ->
264− case schema ^. discriminator of
265− Just pname -> case fromJSON <$> HashMap.lookup pname o of
266− Just (Success ref) -> validateWithSchemaRef ref (Object o)
267− Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg)
268− Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing")
269− Nothing -> do
270− check maxProperties $ \n ->
271− when (size > n) $
272− invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ ")")
273−
274− check minProperties $ \n ->
275− when (size < n) $
276− invalid ("object size is too small (total number of properties should be >=" ++ show n ++ ")")
277−
278− validateRequired
279− validateProps
280− where
281− size = fromIntegral (HashMap.size o)
282−
283− validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)
284− validateReq name =
285− when (not (HashMap.member name o)) $
286− invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))
287−
288− validateProps = withSchema $ \schema -> do
289− for_ (HashMap.toList o) $ \(k, v) ->
290− case v of
291− Null | not (k `elem` (schema ^. required)) -> valid -- null is fine for non-required property
292− _ ->
293− case HashMap.lookup k (schema ^. properties) of
294− Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v
295− Just s -> validateWithSchemaRef s v
296−
297−validateEnum :: Value -> Validation (ParamSchema t) ()
298−validateEnum value = do
299− check enum_ $ \xs ->
300− when (value `notElem` xs) $
301− invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
302−
303−validateSchemaType :: Value -> Validation Schema ()
304−validateSchemaType value = withSchema $ \schema ->
305− case (schema ^. type_, value) of
306− (SwaggerNull, Null) -> valid
307− (SwaggerBoolean, Bool _) -> valid
308− (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
309− (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
310− (SwaggerString, String s) -> sub_ paramSchema (validateString s)
311− (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
312− (SwaggerObject, Object o) -> validateObject o
313− (t, _) -> invalid $ "expected JSON value of type " ++ show t
314−
315−validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
316−validateParamSchemaType value = withSchema $ \schema ->
317− case (schema ^. type_, value) of
318− (SwaggerBoolean, Bool _) -> valid
319− (SwaggerInteger, Number n) -> validateInteger n
320− (SwaggerNumber, Number n) -> validateNumber n
321− (SwaggerString, String s) -> validateString s
322− (SwaggerArray, Array xs) -> validateArray xs
323− (t, _) -> invalid $ "expected JSON value of type " ++ show t
9+module Data.Swagger.Schema.Validation (
10+ validateToJSON,
11+ validateToJSONWithPatternChecker,
12+ ValidationError,
13+) where
32414
15+import Data.Swagger.Internal.Schema.Validation