@@ -18,7 +18,7 @@ import Control.Lens
18import Control.Monad.Reader
18import Control.Monad.Reader
20import Data.Aeson
20import Data.Aeson
21−import Data.Foldable (traverse_)
21+import Data.Foldable (traverse_, for_)
22import Data.HashMap.Strict (HashMap)
22import Data.HashMap.Strict (HashMap)
23import qualified Data.HashMap.Strict as HashMap
23import qualified Data.HashMap.Strict as HashMap
24import qualified "unordered-containers" Data.HashSet as HashSet
24import qualified "unordered-containers" Data.HashSet as HashSet
@@ -42,13 +42,18 @@ instance Applicative ValidationResult where
42 ValidationFailed xs <*> _ = ValidationFailed xs
42 ValidationFailed xs <*> _ = ValidationFailed xs
43 _ <*> ValidationFailed ys = ValidationFailed ys
43 _ <*> ValidationFailed ys = ValidationFailed ys
45+instance Alternative ValidationResult where
46+ empty = ValidationFailed []
47+ ValidationPassed x <|> _ = ValidationPassed x
45instance Monad ValidationResult where
50instance Monad ValidationResult where
46 return = pure
51 return = pure
47 ValidationPassed x >>= f = f x
52 ValidationPassed x >>= f = f x
48 ValidationFailed msg >>= _ = ValidationFailed msg
53 ValidationFailed msg >>= _ = ValidationFailed msg
50newtype Validation a = Validation { runValidation :: ReaderT (HashMap Text Schema) ValidationResult a }
55newtype Validation a = Validation { runValidation :: ReaderT (HashMap Text Schema) ValidationResult a }
51− deriving (Functor, Applicative, Monad, MonadReader (HashMap Text Schema))
56+ deriving (Functor, Applicative, Alternative, Monad, MonadReader (HashMap Text Schema))
53invalid :: String -> Validation a
58invalid :: String -> Validation a
54invalid msg = Validation (ReaderT (const (ValidationFailed [msg])))
59invalid msg = Validation (ReaderT (const (ValidationFailed [msg])))
@@ -136,8 +141,26 @@ validateWithSchema schema value
137 allUnique = Vector.length xs == HashSet.size (HashSet.fromList (Vector.toList xs))
142 allUnique = Vector.length xs == HashSet.size (HashSet.fromList (Vector.toList xs))
139− validateObject o
144+ validateObject o = case schema ^. schemaDiscriminator of
140− = valid
145+ Just name -> validateWithSchemaRef (Ref (Reference name)) value
147+ when' (fromIntegral (HashMap.size o) >) schemaMaxProperties
148+ (\n -> invalid $ "object size exceeds maximum (total number of properties should be <=" ++ show n ++ "): " ++ show (encode o))
149+ *> when' (fromIntegral (HashMap.size o) <) schemaMaxProperties
150+ (\n -> invalid $ "object size is too small (total number of properties should be >=" ++ show n ++ "): " ++ show (encode o))
154+ validateRequired = traverse_ validateReq (schema ^. schemaRequired)
155+ validateReq name = when (not (HashMap.member name o))
156+ (invalid $ "property " ++ show name ++ " is required, but not found in " ++ show (encode o))
158+ validateProps = for_ (HashMap.toList o) $ \(k, v) ->
159+ case HashMap.lookup k (schema ^. schemaProperties) of
160+ Nothing -> case schema ^. schemaAdditionalProperties of
161+ Nothing -> valid -- TODO: issue a warning
162+ Just s -> validateWithSchema s v
163+ Just s -> validateWithSchemaRef s v
142 validateEnum = case schema ^. enum_ of
165 validateEnum = case schema ^. enum_ of
143 Nothing -> valid
166 Nothing -> valid