@@ -1,8 +1,14 @@
11{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
24{-# LANGUAGE GADTs #-}
35{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
48{-# LANGUAGE PackageImports #-}
59{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE UndecidableInstances #-}
612-- |
713-- Module: Data.Swagger.Schema.Validate
814-- Copyright: (c) 2015 GetShopTV
@@ -15,178 +21,255 @@ module Data.Swagger.Schema.Validation where
1521
1622import Control.Applicative
1723import Control.Lens
18−import Control.Monad.Reader
24+import Control.Lens.TH
25+import Control.Monad (when)
1926
20−import Data.Aeson
27+import Data.Aeson hiding (Result)
2128import Data.Foldable (traverse_, for_, sequenceA_)
29+import Data.HashMap.Strict (HashMap)
2230import qualified Data.HashMap.Strict as HashMap
2331import qualified "unordered-containers" Data.HashSet as HashSet
24−import Data.Scientific (isInteger)
32+import Data.Monoid
33+import Data.Scientific (Scientific, isInteger)
2534import Data.Text (Text)
2635import qualified Data.Text as Text
36+import Data.Vector (Vector)
2737import qualified Data.Vector as Vector
2838
2939import Data.Swagger.Internal
3040import Data.Swagger.Lens
3141
32−data ValidationResult a
33− = ValidationFailed [ValidationError]
34− | ValidationPassed a
42+
43+data Result a
44+ = Failed [String]
45+ | Passed a
3546 deriving (Eq, Show, Functor)
3647
37−instance Applicative ValidationResult where
38− pure = ValidationPassed
39− ValidationPassed f <*> ValidationPassed x = ValidationPassed (f x)
40− ValidationFailed xs <*> ValidationFailed ys = ValidationFailed (xs ++ ys)
41− ValidationFailed xs <*> _ = ValidationFailed xs
42− _ <*> ValidationFailed ys = ValidationFailed ys
48+instance Applicative Result where
49+ pure = Passed
50+ Passed f <*> Passed x = Passed (f x)
51+ Failed xs <*> Failed ys = Failed (xs <> ys)
52+ Failed xs <*> _ = Failed xs
53+ _ <*> Failed ys = Failed ys
4354
44−instance Alternative ValidationResult where
45− empty = ValidationFailed []
46− ValidationPassed x <|> _ = ValidationPassed x
47− _ <|> y = y
55+instance Alternative Result where
56+ empty = Failed mempty
57+ Passed x <|> _ = Passed x
58+ _ <|> y = y
4859
49−instance Monad ValidationResult where
60+instance Monad Result where
5061 return = pure
51− ValidationPassed x >>= f = f x
52− ValidationFailed msg >>= _ = ValidationFailed msg
62+ Passed x >>= f = f x
63+ Failed xs >>= f = Failed xs
5364
54−data ValidationConfig = ValidationConfig
55− { validationPatternChecker :: Pattern -> Text -> Bool
56− , validationDefinitions :: Definitions Schema
65+data Config = Config
66+ { configPatternChecker :: Pattern -> Text -> Bool
67+ , configDefinitions :: Definitions Schema
5768 }
5869
59−-- | Default @'ValidationConfig'@:
70+-- | Default @'Config'@:
6071--
6172-- @
62−-- defaultValidationConfig = 'ValidationConfig'
63−-- { 'validationPatternChecker' = \_pattern _str -> True
64−-- , 'validationDefinitions' = mempty
73+-- defaultConfig = 'Config'
74+-- { 'configPatternChecker' = \_pattern _str -> True
75+-- , 'configDefinitions' = mempty
6576-- }
6677-- @
67−defaultValidationConfig :: ValidationConfig
68−defaultValidationConfig = ValidationConfig
69− { validationPatternChecker = \_pattern _str -> True
70− , validationDefinitions = mempty
78+defaultConfig :: Config
79+defaultConfig = Config
80+ { configPatternChecker = \_pattern _str -> True
81+ , configDefinitions = mempty
7182 }
7283
73−newtype Validation a = Validation { runValidation :: ReaderT ValidationConfig ValidationResult a }
74− deriving (Functor, Applicative, Alternative, Monad, MonadReader ValidationConfig)
84+newtype Validation s a = Validation { runValidation :: Config -> s -> Result a }
85+ deriving (Functor)
86+
87+instance Applicative (Validation schema) where
88+ pure x = Validation (\_ _ -> pure x)
89+ Validation f <*> Validation x = Validation (\c s -> f c s <*> x c s)
90+
91+instance Alternative (Validation schema) where
92+ empty = Validation (\_ _ -> empty)
93+ Validation x <|> Validation y = Validation (\c s -> x c s <|> y c s)
94+
95+instance Profunctor Validation where
96+ dimap f g (Validation k) = Validation (\c s -> fmap g (k c (f s)))
97+
98+instance Choice Validation where
99+ left' (Validation g) = Validation (\c -> either (fmap Left . g c) (pure . Right))
100+ right' (Validation g) = Validation (\c -> either (pure . Left) (fmap Right . g c))
101+
102+instance Monad (Validation s) where
103+ return = pure
104+ Validation x >>= f = Validation (\c s -> x c s >>= \x -> runValidation (f x) c s)
105+ (>>) = (*>)
106+
107+withConfig :: (Config -> Validation s a) -> Validation s a
108+withConfig f = Validation (\c -> runValidation (f c) c)
109+
110+withSchema :: (s -> Validation s a) -> Validation s a
111+withSchema f = Validation (\c s -> runValidation (f s) c s)
75112
76−invalid :: String -> Validation a
77−invalid msg = Validation (ReaderT (const (ValidationFailed [msg])))
113+invalid :: String -> Validation schema a
114+invalid msg = Validation (\_ _ -> Failed [msg])
78115
79−valid :: Validation ()
116+valid :: Validation schema ()
80117valid = pure ()
81118
82−unref :: Reference -> Validation Schema
83−unref (Reference ref) = do
84− ms <- asks (HashMap.lookup ref . validationDefinitions)
85− case ms of
119+check :: Lens' s (Maybe a) -> (a -> Validation s ()) -> Validation s ()
120+check l g = withSchema $ \schema ->
121+ case schema ^. l of
122+ Nothing -> valid
123+ Just x -> g x
124+
125+sub :: t -> Validation t a -> Validation s a
126+sub = lmap . const
127+
128+sub_ :: Getting a s a -> Validation a r -> Validation s r
129+sub_ = lmap . view
130+
131+withRef :: Reference -> (Schema -> Validation s a) -> Validation s a
132+withRef (Reference ref) f = withConfig $ \cfg ->
133+ case HashMap.lookup ref (configDefinitions cfg) of
86134 Nothing -> invalid $ "unknown schema " ++ show ref
87− Just s -> pure s
135+ Just s -> f s
136+
137+validateWithSchemaRef :: Referenced Schema -> Value -> Validation s ()
138+validateWithSchemaRef (Ref ref) js = withRef ref $ \schema -> sub schema (validateWithSchema js)
139+validateWithSchemaRef (Inline s) js = sub s (validateWithSchema js)
140+
141+validateWithSchema :: Value -> Validation Schema ()
142+validateWithSchema value = do
143+ validateSchemaType value
144+ sub_ paramSchema $ validateEnum value
145+
146+validateWithParamSchema :: Value -> Validation (ParamSchema t) ()
147+validateWithParamSchema value = do
148+ validateParamSchemaType value
149+ validateEnum value
150+
151+validateInteger :: Scientific -> Validation (ParamSchema t) ()
152+validateInteger n = do
153+ when (not (isInteger n)) $
154+ invalid ("not an integer: " ++ show n)
155+ validateNumber n
156+
157+validateNumber :: Scientific -> Validation (ParamSchema t) ()
158+validateNumber n = withConfig $ \cfg -> withSchema $ \schema -> do
159+ let exMax = Just True == schema ^. exclusiveMaximum
160+ exMin = Just True == schema ^. exclusiveMinimum
88161
89−type ValidationError = String
162+ check maximum_ $ \m ->
163+ when (if exMax then (n >= m) else (n > m)) $
164+ invalid ("value " ++ show n ++ " exceeds maximum (should be " ++ if exMax then "<" else "<=" ++ show m ++ ")")
90165
91−validateWithSchemaRef :: Referenced Schema -> Value -> Validation ()
92−validateWithSchemaRef (Ref ref) js = unref ref >>= flip validateWithSchema js
93−validateWithSchemaRef (Inline s) js = validateWithSchema s js
166+ check minimum_ $ \m ->
167+ when (if exMin then (n <= m) else (n < m)) $
168+ invalid ("value " ++ show n ++ " falls below minimum (should be " ++ if exMin then ">" else ">=" ++ show m ++ ")")
94169
95−validateWithSchema :: Schema -> Value -> Validation ()
96−validateWithSchema schema value
97− = validateType
98− *> validateEnum
170+ check multipleOf $ \k ->
171+ when (not (isInteger (n / k))) $
172+ invalid ("expected a multiple of " ++ show k ++ " but got " ++ show n)
99173
174+validateString :: Text -> Validation (ParamSchema t) ()
175+validateString s = do
176+ check maxLength $ \n ->
177+ when (len > fromInteger n) $
178+ invalid ("string is too long (length should be <=" ++ show n ++ "): " ++ show s)
179+
180+ check minLength $ \n ->
181+ when (len < fromInteger n) $
182+ invalid ("string is too short (length should be >=" ++ show n ++ "): " ++ show s)
183+
184+ check pattern $ \regex -> do
185+ withConfig $ \cfg -> do
186+ when (not (configPatternChecker cfg regex s)) $
187+ invalid ("string does not match pattern " ++ show regex ++ ": " ++ show s)
188+ where
189+ len = Text.length s
190+
191+validateArray :: Vector Value -> Validation (ParamSchema t) ()
192+validateArray xs = do
193+ check maxItems $ \n ->
194+ when (len > fromInteger n) $
195+ invalid ("array exceeds maximum size (should be <=" ++ show n ++ "): " ++ show (encode xs))
196+
197+ check minItems $ \n ->
198+ when (len < fromInteger n) $
199+ invalid ("array is too short (size should be >=" ++ show n ++ "): " ++ show (encode xs))
200+
201+ check items $ \case
202+ SwaggerItemsPrimitive _ itemSchema -> sub itemSchema $ traverse_ validateWithParamSchema xs
203+ SwaggerItemsObject itemSchema -> traverse_ (validateWithSchemaRef itemSchema) xs
204+ SwaggerItemsArray itemSchemas -> do
205+ when (len /= length itemSchemas) $
206+ invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ "): " ++ show (encode xs))
207+ sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
208+
209+ check uniqueItems $ \unique ->
210+ when (unique && not allUnique) $
211+ invalid ("array is expected to contain unique items, but it does not: " ++ show (encode xs))
212+ where
213+ len = Vector.length xs
214+ allUnique = len == HashSet.size (HashSet.fromList (Vector.toList xs))
215+
216+validateObject :: HashMap Text Value -> Validation Schema ()
217+validateObject o = withSchema $ \schema ->
218+ case schema ^. discriminator of
219+ Just pname -> case fromJSON <$> HashMap.lookup pname o of
220+ Just (Success ref) -> validateWithSchemaRef ref (Object o)
221+ 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))
223+ Nothing -> do
224+ check maxProperties $ \n ->
225+ when (size > n) $
226+ invalid ("object size exceeds maximum (total number of properties should be <=" ++ show n ++ "): " ++ show (encode o))
227+
228+ check minProperties $ \n ->
229+ when (size < n) $
230+ invalid ("object size is too small (total number of properties should be >=" ++ show n ++ "): " ++ show (encode o))
231+
232+ validateRequired
233+ validateProps
100234 where
101− when' :: (a -> Bool) -> Lens' Schema (Maybe a) -> (a -> Validation ()) -> Validation ()
102− when' p l m = do
103− case schema ^. l of
104− Nothing -> valid
105− Just x -> when (p x) (m x)
106−
107− validateType =
108− case (schema ^. type_, value) of
109− (SwaggerNull, Null) -> valid
110− (SwaggerBoolean, Bool _) -> valid
111− (SwaggerInteger, Number n) -> validateInteger n
112− (SwaggerNumber, Number n) -> validateNumber n
113− (SwaggerString, String s) -> validateString s
114− (SwaggerArray, Array xs) -> validateArray xs
115− (SwaggerObject, Object o) -> validateObject o
116− (t, _) -> invalid $ "expected JSON value of type " ++ show t ++ ": " ++ show (encode value)
117−
118− validateInteger n
119− = when (not (isInteger n)) (invalid $ "not an integer: " ++ show n)
120− *> validateNumber n
121−
122− exMax = Just True == schema ^. exclusiveMaximum
123− exMin = Just True == schema ^. exclusiveMinimum
124−
125− validateNumber n
126− = (if exMax
127− then when' (n >=) maximum_ $ \m ->
128− invalid $ "value " ++ show n ++ " exceeds maximum (should be <" ++ show m ++ ")"
129− else when' (n >) maximum_ $ \m ->
130− invalid $ "value " ++ show n ++ " exceeds maximum (should be <=" ++ show m ++ ")")
131− *> (if exMin
132− then when' (n <=) minimum_ $ \m ->
133− invalid $ "value " ++ show n ++ " is less than minimum (should be >" ++ show m ++ ")"
134− else when' (n <) minimum_ $ \m ->
135− invalid $ "value " ++ show n ++ " is less than minimum (should be >=" ++ show m ++ ")")
136− *> when' (not . isInteger . (n /)) multipleOf
137− (\k -> invalid $ "expected a multiple of " ++ show k ++ " but got " ++ show n)
138−
139− validateString s
140− = when' (fromIntegral (Text.length s) >) maxLength
141− (\n -> invalid $ "string exceeds maximum length (should be <=" ++ show n ++ "): " ++ show s)
142− *> when' (fromIntegral (Text.length s) <) minLength
143− (\n -> invalid $ "string is too short (length should be >=" ++ show n ++ "): " ++ show s)
144− *> validatePattern
145− where
146− validatePattern = do
147− check <- asks validationPatternChecker
148− when' (`check` s) pattern
149− (\regex -> invalid $ "string does not match pattern " ++ show regex)
150−
151− validateArray xs
152− = when' (fromIntegral (Vector.length xs) >) maxItems
153− (\n -> invalid $ "array exceeds maximum size (should be <=" ++ show n ++ "): " ++ show (encode xs))
154− *> when' (fromIntegral (Vector.length xs) <) minItems
155− (\n -> invalid $ "array is too short (size should be >=" ++ show n ++ "): " ++ show (encode xs))
156− *> case schema ^. items of
157− Just (SwaggerItemsObject itemSchema) -> traverse_ (validateWithSchemaRef itemSchema) xs
158− Just (SwaggerItemsArray itemSchemas) ->
159− when (Vector.length xs /= length itemSchemas)
160− (invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ "): " ++ show (encode xs)))
161− *> sequenceA_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
162− Nothing -> invalid "invalid schema: array item schema expected"
163− *> when ((Just True == schema ^. uniqueItems) && not allUnique)
164− (invalid $ "array is expected to contain unique items, but it does not: " ++ show (encode xs))
165− where
166− allUnique = Vector.length xs == HashSet.size (HashSet.fromList (Vector.toList xs))
167−
168− validateObject o = case schema ^. discriminator of
169− Just name -> validateWithSchemaRef (Ref (Reference name)) value
170− Nothing ->
171− when' (fromIntegral (HashMap.size o) >) maxProperties
172− (\n -> invalid $ "object size exceeds maximum (total number of properties should be <=" ++ show n ++ "): " ++ show (encode o))
173− *> when' (fromIntegral (HashMap.size o) <) minProperties
174− (\n -> invalid $ "object size is too small (total number of properties should be >=" ++ show n ++ "): " ++ show (encode o))
175− *> validateRequired
176− *> validateProps
177− where
178− validateRequired = traverse_ validateReq (schema ^. required)
179− validateReq name = when (not (HashMap.member name o))
180− (invalid $ "property " ++ show name ++ " is required, but not found in " ++ show (encode o))
181−
182− validateProps = for_ (HashMap.toList o) $ \(k, v) ->
183− case HashMap.lookup k (schema ^. properties) of
184− Nothing -> case schema ^. additionalProperties of
185− Nothing -> valid -- TODO: issue a warning
186− Just s -> validateWithSchema s v
187− Just s -> validateWithSchemaRef s v
188−
189− validateEnum = case schema ^. enum_ of
190− Nothing -> valid
191− Just xs -> when (value `notElem` xs) $ invalid $ "expected one of " ++ show (encode xs) ++ " but got " ++ show value
235+ size = fromIntegral (HashMap.size o)
236+
237+ validateRequired = withSchema $ \schema -> traverse_ validateReq (schema ^. required)
238+ validateReq name =
239+ when (not (HashMap.member name o)) $
240+ invalid ("property " ++ show name ++ " is required, but not found in " ++ show (encode o))
241+
242+ validateProps = withSchema $ \schema -> do
243+ for_ (HashMap.toList o) $ \(k, v) ->
244+ case HashMap.lookup k (schema ^. properties) of
245+ Nothing -> check additionalProperties $ \s -> sub s $ validateWithSchema v
246+ Just s -> validateWithSchemaRef s v
247+
248+validateEnum :: Value -> Validation (ParamSchema t) ()
249+validateEnum value = do
250+ check enum_ $ \xs ->
251+ when (value `notElem` xs) $
252+ invalid ("expected one of " ++ show (encode xs) ++ " but got " ++ show value)
253+
254+validateSchemaType :: Value -> Validation Schema ()
255+validateSchemaType value = withSchema $ \schema ->
256+ case (schema ^. type_, value) of
257+ (SwaggerNull, Null) -> valid
258+ (SwaggerBoolean, Bool _) -> valid
259+ (SwaggerInteger, Number n) -> sub_ paramSchema (validateInteger n)
260+ (SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n)
261+ (SwaggerString, String s) -> sub_ paramSchema (validateString s)
262+ (SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs)
263+ (SwaggerObject, Object o) -> validateObject o
264+ (t, _) -> invalid $ "expected JSON value of type " ++ show t ++ ": " ++ show (encode value)
265+
266+validateParamSchemaType :: Value -> Validation (ParamSchema t) ()
267+validateParamSchemaType value = withSchema $ \schema ->
268+ case (schema ^. type_, value) of
269+ (SwaggerBoolean, Bool _) -> valid
270+ (SwaggerInteger, Number n) -> validateInteger n
271+ (SwaggerNumber, Number n) -> validateNumber n
272+ (SwaggerString, String s) -> validateString s
273+ (SwaggerArray, Array xs) -> validateArray xs
274+ (t, _) -> invalid $ "expected JSON value of type " ++ show t ++ ": " ++ show (encode value)
192275