@@ -0,0 +1,145 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE PackageImports #-}
5+{-# LANGUAGE RankNTypes #-}
6+-- |
7+-- Module: Data.Swagger.Schema.Validate
8+-- Copyright: (c) 2015 GetShopTV
9+-- License: BSD3
10+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
11+-- Stability: experimental
12+--
13+-- Validate JSON values with Swagger Schema.
14+module Data.Swagger.Schema.Validate where
15+
16+import Control.Applicative
17+import Control.Lens
18+import Control.Monad.Reader
19+
20+import Data.Aeson
21+import Data.Foldable (traverse_)
22+import Data.HashMap.Strict (HashMap)
23+import qualified Data.HashMap.Strict as HashMap
24+import qualified "unordered-containers" Data.HashSet as HashSet
25+import Data.Scientific (isInteger)
26+import Data.Text (Text)
27+import qualified Data.Text as Text
28+import qualified Data.Vector as Vector
29+
30+import Data.Swagger.Internal
31+import Data.Swagger.Lens
32+
33+data ValidationResult a
34+ = ValidationFailed [ValidationError]
35+ | ValidationPassed a
36+ deriving (Eq, Show, Functor)
37+
38+instance Applicative ValidationResult where
39+ pure = ValidationPassed
40+ ValidationPassed f <*> ValidationPassed x = ValidationPassed (f x)
41+ ValidationFailed xs <*> ValidationFailed ys = ValidationFailed (xs ++ ys)
42+ ValidationFailed xs <*> _ = ValidationFailed xs
43+ _ <*> ValidationFailed ys = ValidationFailed ys
44+
45+instance Monad ValidationResult where
46+ return = pure
47+ ValidationPassed x >>= f = f x
48+ ValidationFailed msg >>= _ = ValidationFailed msg
49+
50+newtype Validation a = Validation { runValidation :: ReaderT (HashMap Text Schema) ValidationResult a }
51+ deriving (Functor, Applicative, Monad, MonadReader (HashMap Text Schema))
52+
53+invalid :: String -> Validation a
54+invalid msg = Validation (ReaderT (const (ValidationFailed [msg])))
55+
56+valid :: Validation ()
57+valid = pure ()
58+
59+unref :: Reference -> Validation Schema
60+unref (Reference ref) = do
61+ ms <- asks (HashMap.lookup ref)
62+ case ms of
63+ Nothing -> invalid $ "unknown schema " ++ show ref
64+ Just s -> pure s
65+
66+type ValidationError = String
67+
68+validateWithSchemaRef :: Referenced Schema -> Value -> Validation ()
69+validateWithSchemaRef (Ref ref) js = unref ref >>= flip validateWithSchema js
70+validateWithSchemaRef (Inline s) js = validateWithSchema s js
71+
72+validateWithSchema :: Schema -> Value -> Validation ()
73+validateWithSchema schema value
74+ = validateType
75+ *> validateEnum
76+
77+ where
78+ when' :: (a -> Bool) -> Lens' Schema (Maybe a) -> (a -> Validation ()) -> Validation ()
79+ when' p l m = do
80+ case schema ^. l of
81+ Nothing -> valid
82+ Just x -> when (p x) (m x)
83+
84+ validateType =
85+ case (schema ^. type_, value) of
86+ (SwaggerNull, Null) -> valid
87+ (SwaggerBoolean, Bool _) -> valid
88+ (SwaggerInteger, Number n) -> validateInteger n
89+ (SwaggerNumber, Number n) -> validateNumber n
90+ (SwaggerString, String s) -> validateString s
91+ (SwaggerArray, Array xs) -> validateArray xs
92+ (SwaggerObject, Object o) -> validateObject o
93+
94+ validateInteger n
95+ = when (not (isInteger n)) (invalid $ "not an integer: " ++ show n)
96+ *> validateNumber n
97+
98+ exMax = Just True == schema ^. exclusiveMaximum
99+ exMin = Just True == schema ^. exclusiveMinimum
100+
101+ validateNumber n
102+ = (if exMax
103+ then when' (n >=) maximum_ $ \m ->
104+ invalid $ "value " ++ show n ++ " exceeds maximum (should be <" ++ show m ++ ")"
105+ else when' (n >) maximum_ $ \m ->
106+ invalid $ "value " ++ show n ++ " exceeds maximum (should be <=" ++ show m ++ ")")
107+ *> (if exMin
108+ then when' (n <=) minimum_ $ \m ->
109+ invalid $ "value " ++ show n ++ " is less than minimum (should be >" ++ show m ++ ")"
110+ else when' (n <) minimum_ $ \m ->
111+ invalid $ "value " ++ show n ++ " is less than minimum (should be >=" ++ show m ++ ")")
112+ *> when' (not . isInteger . (n /)) multipleOf
113+ (\k -> invalid $ "expected a multiple of " ++ show k ++ " but got " ++ show n)
114+
115+ -- TODO: validate schemaPattern
116+ validateString s
117+ = when' (fromIntegral (Text.length s) >) maxLength
118+ (\n -> invalid $ "string exceeds maximum length (should be <=" ++ show n ++ "): " ++ show s)
119+ *> when' (fromIntegral (Text.length s) <) minLength
120+ (\n -> invalid $ "string is too short (length should be >=" ++ show n ++ "): " ++ show s)
121+
122+ validateArray xs
123+ = when' (fromIntegral (Vector.length xs) >) maxItems
124+ (\n -> invalid $ "array exceeds maximum size (should be <=" ++ show n ++ "): " ++ show (encode xs))
125+ *> when' (fromIntegral (Vector.length xs) <) minItems
126+ (\n -> invalid $ "array is too short (size should be >=" ++ show n ++ "): " ++ show (encode xs))
127+ *> case schema ^. items of
128+ Just (SwaggerItemsObject itemSchema) -> traverse_ (validateWithSchemaRef itemSchema) xs
129+ Just (SwaggerItemsArray itemSchemas) ->
130+ when (Vector.length xs /= length itemSchemas)
131+ (invalid ("array size is invalid (should be exactly " ++ show (length itemSchemas) ++ "): " ++ show (encode xs)))
132+ *> sequence_ (zipWith validateWithSchemaRef itemSchemas (Vector.toList xs))
133+ Nothing -> invalid "invalid schema: array item schema expected"
134+ *> when ((Just True == schema ^. uniqueItems) && not allUnique)
135+ (invalid $ "array is expected to contain unique items, but it does not: " ++ show (encode xs))
136+ where
137+ allUnique = Vector.length xs == HashSet.size (HashSet.fromList (Vector.toList xs))
138+
139+ validateObject o
140+ = valid
141+
142+ validateEnum = case schema ^. enum_ of
143+ Nothing -> valid
144+ Just xs -> when (value `notElem` xs) $ invalid $ "expected one of " ++ show (encode xs) ++ " but got " ++ show value
145+