@@ -0,0 +1,324 @@
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 #-}
13+-- |
14+-- Module: Data.Swagger.Internal.Schema.Validation
15+-- Copyright: (c) 2015 GetShopTV
16+-- License: BSD3
17+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
18+-- Stability: experimental
19+--
20+-- Validate JSON values with Swagger Schema.
21+module Data.Swagger.Internal.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
324+