module Data.Aeson.Schema.Validator
( ValidationError
, validate
) where
import Data.Aeson (Value (..))
import qualified Data.Aeson as A
import Data.Attoparsec.Number (Number (..))
import qualified Data.HashMap.Strict as H
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe (isNothing)
import Data.Text (Text, length, unpack)
import qualified Data.Vector as V
import Prelude hiding (foldr, length)
import Text.Regex.PCRE (match)
import Data.Aeson.Schema.Types
import Data.Aeson.Schema.Choice
import Data.Aeson.Schema.Helpers
type ValidationError = String
validationError :: ValidationError -> [ValidationError]
validationError e = [e]
valid :: [ValidationError]
valid = []
validate :: Ord ref
=> Graph Schema ref
-> Schema ref
-> Value
-> [ValidationError]
validate graph schema val = case schemaDRef schema of
Just ref -> case M.lookup ref graph of
Nothing -> validationError "referenced schema is not in map"
Just referencedSchema -> validate graph referencedSchema val
Nothing -> L.concat
[ case schemaType schema of
[t] -> validateType t
ts -> if L.any L.null (map validateType ts) then [] else validationError "no type matched"
, maybeCheck checkEnum $ schemaEnum schema
, concatMap validateTypeDisallowed (schemaDisallow schema)
, concatMap (flip (validate graph) val) (schemaExtends schema)
]
where
validateType (Choice1of2 t) = case (t, val) of
(StringType, String str) -> validateString schema str
(NumberType, Number num) -> validateNumber schema num
(IntegerType, Number num@(I _)) -> validateNumber schema num
(BooleanType, Bool _) -> valid
(ObjectType, Object obj) -> validateObject graph schema obj
(ArrayType, Array arr) -> validateArray graph schema arr
(NullType, Null) -> valid
(AnyType, _) -> case val of
String str -> validateString schema str
Number num -> validateNumber schema num
Object obj -> validateObject graph schema obj
Array arr -> validateArray graph schema arr
_ -> valid
(typ, _) -> validationError $ "type mismatch: expected " ++ show typ ++ " but got " ++ getType val
validateType (Choice2of2 s) = validate graph s val
getType :: A.Value -> String
getType (String _) = "string"
getType (Number _) = "number"
getType (Bool _) = "boolean"
getType (Object _) = "object"
getType (Array _) = "array"
getType Null = "null"
checkEnum e = assert (val `elem` e) "value has to be one of the values in enum"
isType :: Value -> SchemaType -> Bool
isType (String _) StringType = True
isType (Number (I _)) IntegerType = True
isType (Number _) NumberType = True
isType (Bool _) BooleanType = True
isType (Object _) ObjectType = True
isType (Array _) ArrayType = True
isType _ AnyType = True
isType _ _ = False
validateTypeDisallowed (Choice1of2 t) = if isType val t
then validationError $ "values of type " ++ show t ++ " are not allowed here"
else valid
validateTypeDisallowed (Choice2of2 s) = assert (not . L.null $ validate graph s val) "value disallowed"
assert :: Bool -> String -> [ValidationError]
assert True _ = valid
assert False e = validationError e
maybeCheck :: (a -> [ValidationError]) -> Maybe a -> [ValidationError]
maybeCheck p (Just a) = p a
maybeCheck _ _ = valid
validateString :: Schema ref -> Text -> [ValidationError]
validateString schema str = L.concat
[ checkMinLength $ schemaMinLength schema
, maybeCheck checkMaxLength (schemaMaxLength schema)
, maybeCheck checkPattern $ schemaPattern schema
, maybeCheck checkFormat $ schemaFormat schema
]
where
checkMinLength l = assert (length str >= l) $ "length of string must be at least " ++ show l
checkMaxLength l = assert (length str <= l) $ "length of string must be at most " ++ show l
checkPattern (Pattern source compiled) = assert (match compiled $ unpack str) $ "string must match pattern " ++ show source
checkFormat format = maybe valid validationError $ validateFormat format str
validateNumber :: Schema ref -> Number -> [ValidationError]
validateNumber schema num = L.concat
[ maybeCheck (checkMinimum $ schemaExclusiveMinimum schema) $ schemaMinimum schema
, maybeCheck (checkMaximum $ schemaExclusiveMaximum schema) $ schemaMaximum schema
, maybeCheck checkDivisibleBy $ schemaDivisibleBy schema
]
where
checkMinimum excl m = if excl
then assert (num > m) $ "number must be greater than " ++ show m
else assert (num >= m) $ "number must be greater than or equal " ++ show m
checkMaximum excl m = if excl
then assert (num < m) $ "number must be less than " ++ show m
else assert (num <= m) $ "number must be less than or equal " ++ show m
checkDivisibleBy devisor = assert (num `isDivisibleBy` devisor) $ "number must be devisible by " ++ show devisor
validateObject :: Ord ref => Graph Schema ref -> Schema ref -> A.Object -> [ValidationError]
validateObject graph schema obj =
concatMap (uncurry checkKeyValue) (H.toList obj) ++
concatMap checkRequiredProperty requiredProperties
where
checkKeyValue k v = L.concat
[ maybeCheck (flip (validate graph) v) property
, concatMap (flip (validate graph) v . snd) matchingPatternsProperties
, if isNothing property && L.null matchingPatternsProperties
then checkAdditionalProperties (schemaAdditionalProperties schema)
else valid
, maybeCheck checkDependencies $ H.lookup k (schemaDependencies schema)
]
where
property = H.lookup k (schemaProperties schema)
matchingPatternsProperties = filter (flip match (unpack k) . patternCompiled . fst) $ schemaPatternProperties schema
checkAdditionalProperties ap = case ap of
Choice1of2 b -> assert b $ "additional property " ++ unpack k ++ " is not allowed"
Choice2of2 s -> validate graph s v
checkDependencies deps = case deps of
Choice1of2 props -> L.concat $ flip map props $ \prop -> case H.lookup prop obj of
Nothing -> validationError $ "property " ++ unpack k ++ " depends on property " ++ show prop
Just _ -> valid
Choice2of2 depSchema -> validate graph depSchema (Object obj)
requiredProperties = map fst . filter (schemaRequired . snd) . H.toList $ schemaProperties schema
checkRequiredProperty key = case H.lookup key obj of
Nothing -> validationError $ "required property " ++ unpack key ++ " is missing"
Just _ -> valid
validateArray :: Ord ref => Graph Schema ref -> Schema ref -> A.Array -> [ValidationError]
validateArray graph schema arr = L.concat
[ checkMinItems $ schemaMinItems schema
, maybeCheck checkMaxItems $ schemaMaxItems schema
, if schemaUniqueItems schema then checkUnique else valid
, maybeCheck checkItems $ schemaItems schema
]
where
len = V.length arr
list = V.toList arr
checkMinItems m = assert (len >= m) $ "array must have at least " ++ show m ++ " items"
checkMaxItems m = assert (len <= m) $ "array must have at most " ++ show m ++ " items"
checkUnique = assert (vectorUnique arr) "all array items must be unique"
checkItems items = case items of
Choice1of2 s -> assert (V.all (L.null . validate graph s) arr) "all items in the array must validate against the schema given in 'items'"
Choice2of2 ss ->
let additionalItems = drop (L.length ss) list
checkAdditionalItems ai = case ai of
Choice1of2 b -> assert (b || L.null additionalItems) "no additional items allowed"
Choice2of2 additionalSchema -> concatMap (validate graph additionalSchema) additionalItems
in L.concat (zipWith (validate graph) ss list) ++
checkAdditionalItems (schemaAdditionalItems schema)