module Data.JsonSchema.Validators where
import Control.Applicative
import Control.Monad
import Data.Aeson
import Data.Fixed (mod')
import Data.Hashable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Data.JsonPointer
import Data.JsonSchema.Core
import Data.JsonSchema.Reference
import Data.JsonSchema.Utils
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Traversable
import Data.Vector (Vector)
import qualified Data.Vector as V
import Network.HTTP.Types.URI
import Text.RegexPR
noEm :: Text -> Value -> Vector RawSchema
noEm _ _ = V.empty
objEmbed :: Text -> Value -> Vector RawSchema
objEmbed t (Object o) = V.singleton $ RawSchema t o
objEmbed _ _ = V.empty
arrayEmbed :: Text -> Value -> Vector RawSchema
arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs
arrayEmbed _ _ = V.empty
objOrArrayEmbed :: Text -> Value -> Vector RawSchema
objOrArrayEmbed t v@(Object _) = objEmbed t v
objOrArrayEmbed t v@(Array _) = arrayEmbed t v
objOrArrayEmbed _ _ = V.empty
objMembersEmbed :: Text -> Value -> Vector RawSchema
objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o
objMembersEmbed _ _ = V.empty
multipleOf :: ValidatorGen
multipleOf _ _ _ (Number val) = do
greaterThanZero val
Just (\x ->
case x of
(Number y) -> if y `mod'` val /= 0
then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val
else mempty
_ -> mempty)
multipleOf _ _ _ _ = Nothing
maximumVal :: ValidatorGen
maximumVal _ _ s (Number val) =
let f = case H.lookup "exclusiveMaximum" (_rsObject s) of
Just (Bool a) -> if a then (>=) else (>)
_ -> (>)
in Just (\x ->
case x of
(Number y) -> if y `f` val
then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val
else mempty
_ -> mempty)
maximumVal _ _ _ _ = Nothing
minimumVal :: ValidatorGen
minimumVal _ _ s (Number val) =
let f = case H.lookup "exclusiveMinimum" (_rsObject s) of
Just (Bool a) -> if a then (<=) else (<)
_ -> (<)
in Just (\x ->
case x of
(Number y) -> if y `f` val
then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val
else mempty
_ -> mempty)
minimumVal _ _ _ _ = Nothing
maxLength :: ValidatorGen
maxLength _ _ _ v = do
val <- fromJSONInt v
greaterThanZero val
Just (\x ->
case x of
(String y) -> if T.length y > val
then V.singleton $ y <> " is greater than maxLength " <> tshow val
else mempty
_ -> mempty)
minLength :: ValidatorGen
minLength _ _ _ v = do
val <- fromJSONInt v
greaterThanZero val
Just (\x ->
case x of
(String y) -> if T.length y < val
then V.singleton $ y <> " is less than minLength " <> tshow val
else mempty
_ -> mempty)
pattern :: ValidatorGen
pattern _ _ _ (String val) =
Just (\x ->
case x of
(String t) ->
case matchRegexPR (T.unpack val) (T.unpack t) of
Nothing -> V.singleton $ t <> " fails to validate against pattern " <> val
Just _ -> mempty
_ -> mempty)
pattern _ _ _ _ = Nothing
items :: ValidatorGen
items spec g s (Object val) =
let sub = compile spec g (RawSchema (_rsURI s) val)
in Just (\x ->
case x of
(Array ys) -> ys >>= validate sub
_ -> mempty)
items spec g s (Array vs) = do
os <- traverse toObj vs
let ss = compile spec g . RawSchema (_rsURI s) <$> os
let addItems = do
a <- H.lookup "additionalItems" (_rsObject s)
additionalItems' spec g s a
Just (\x ->
case x of
(Array ys) ->
let extras = V.drop (V.length os) ys
in join (V.zipWith validate ss ys) <> runMaybeVal addItems (Array extras)
_ -> mempty)
items _ _ _ _ = Nothing
additionalItems' :: ValidatorGen
additionalItems' _ _ _ (Bool val) =
Just (\x ->
case x of
(Array ys) -> if not val && V.length ys > 0
then V.singleton ("Val error against additionalItems false for: " <> tshow x)
else mempty
_ -> mempty)
additionalItems' spec g s (Object val) =
let sub = compile spec g (RawSchema (_rsURI s) val)
in Just (\x ->
case x of
(Array ys) -> ys >>= validate sub
_ -> mempty)
additionalItems' _ _ _ _ = Nothing
maxItems :: ValidatorGen
maxItems _ _ _ v = do
val <- fromJSONInt v
greaterThanZero val
Just (\x ->
case x of
(Array ys) -> if V.length ys > val
then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val
else mempty
_ -> mempty)
minItems :: ValidatorGen
minItems _ _ _ v = do
val <- fromJSONInt v
greaterThanZero val
Just (\x ->
case x of
(Array ys) -> if V.length ys < val
then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val
else mempty
_ -> mempty)
uniqueItems :: ValidatorGen
uniqueItems _ _ _ (Bool val) = do
unless val Nothing
Just (\x ->
case x of
(Array ys) -> if allUnique ys
then mempty
else V.singleton
("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)
_ -> mempty)
uniqueItems _ _ _ _ = Nothing
maxProperties :: ValidatorGen
maxProperties _ _ _ v = do
val <- fromJSONInt v
greaterThanZero val
Just (\x ->
case x of
(Object o) -> if H.size o > val
then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val
else mempty
_ -> mempty)
minProperties :: ValidatorGen
minProperties _ _ _ v = do
val <- fromJSONInt v
greaterThanZero val
Just (\x ->
case x of
(Object o) -> if H.size o < val
then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val
else mempty
_ -> mempty)
required :: ValidatorGen
required _ _ _ (Array vs) = do
when (V.length vs == 0) Nothing
ts <- traverse toTxt vs
let a = vectorToMap ts
when (H.size a /= V.length ts) Nothing
Just (\x ->
case x of
(Object o) -> if H.size (H.difference a o) > 0
then V.singleton $ "the keys of " <> tshow o
<> " don't contain all the required elements " <> tshow vs
else mempty
_ -> mempty)
where
vectorToMap :: (Eq a, Hashable a) => Vector a -> HashMap a Bool
vectorToMap vec = H.fromList $ zip (V.toList vec) (repeat True)
required _ _ _ _ = Nothing
properties :: ValidatorGen
properties spec g s v = do
let mProps = properties'' spec g s v
let mPatProp = do
aV <- H.lookup "patternProperties" (_rsObject s)
patternProperties'' spec g s aV
let mAdd = do
aVal <- H.lookup "additionalProperties" (_rsObject s)
additionalProperties' spec g s aVal
when (isNothing mProps && isNothing mPatProp && isNothing mAdd) Nothing
Just (\x ->
case x of
(Object y) ->
let (e1s, remaining) = runMaybeVal' mProps (Object y)
(_, remaining') = runMaybeVal' mPatProp remaining
(e2s, _) = runMaybeVal' mPatProp (Object y)
in e1s <> e2s <> runMaybeVal mAdd remaining'
_ -> mempty)
properties''
:: Spec
-> Graph
-> RawSchema
-> Value
-> Maybe (Value -> (Vector ValErr, Value))
properties'' spec g s (Object val) = do
os <- traverse toObj val
let oss = compile spec g . RawSchema (_rsURI s) <$> os
Just (\x ->
case x of
(Object y) -> ( join . V.fromList . H.elems $ H.intersectionWith validate oss y
, Object (H.difference y oss))
z -> (mempty, z))
properties'' _ _ _ _ = Nothing
patternProperties''
:: Spec
-> Graph
-> RawSchema
-> Value
-> Maybe (Value -> (Vector ValErr, Value))
patternProperties'' spec g s (Object val) = do
os <- traverse toObj val
let vs = compile spec g . RawSchema (_rsURI s) <$> os
Just (\x ->
case x of
(Object y) -> let ms = matches (V.fromList . H.toList $ vs) <$> (V.fromList . H.toList $ y)
in (ms >>= runVals, leftovers ms)
_ -> (mempty, x))
where
matches :: Vector (Text, Schema) -> (Text, Value) -> (Text, Value, Vector Schema)
matches ss (k, v) = (k, v, ss >>= match k)
match :: Text -> (Text, Schema) -> Vector Schema
match k (r, sc) =
case matchRegexPR (T.unpack r) (T.unpack k) of
Nothing -> mempty
Just _ -> V.singleton sc
runVals :: (Text, Value, Vector Schema) -> Vector ValErr
runVals (_,v,ss) = join $ validate <$> ss <*> pure v
leftovers :: Vector (Text, Value, Vector Schema) -> Value
leftovers possiblyMatched =
let unmatched = V.filter (\(_,_,ss) -> V.length ss == 0) possiblyMatched
in Object . H.fromList . V.toList $ (\(v,k,_) -> (v,k)) <$> unmatched
patternProperties'' _ _ _ _ = Nothing
patternProperties :: ValidatorGen
patternProperties spec g s v = do
when (H.member "properties" (_rsObject s)) Nothing
let mPatProp = patternProperties'' spec g s v
let mAdd = do
aVal <- H.lookup "additionalProperties" (_rsObject s)
additionalProperties' spec g s aVal
when (isNothing mPatProp && isNothing mAdd) Nothing
Just (\x ->
case x of
(Object y) ->
let (e2s, remaining') = runMaybeVal' mPatProp (Object y)
in e2s <> runMaybeVal mAdd remaining'
_ -> mempty)
additionalProperties' :: ValidatorGen
additionalProperties' _ _ _ (Bool val) =
Just (\x ->
case x of
(Object y) -> if not val && H.size y > 0
then V.singleton ("Val error against additionalProperties false for: " <> tshow x)
else mempty
_ -> mempty)
additionalProperties' spec g s (Object val) =
let sub = compile spec g (RawSchema (_rsURI s) val)
in Just (\x ->
case x of
(Object y) -> (V.fromList . H.elems $ y) >>= validate sub
_ -> mempty)
additionalProperties' _ _ _ _ = Nothing
additionalProperties :: ValidatorGen
additionalProperties spec g s v = do
when (H.member "properties" (_rsObject s)) Nothing
when (H.member "patternProperties" (_rsObject s)) Nothing
additionalProperties' spec g s v
dependencies :: ValidatorGen
dependencies spec g s (Object val) = do
let vs = V.fromList $ H.toList val
let schemaDeps = vs >>= toSchemaDep spec g
let propDeps = vs >>= toPropDep
when (V.length schemaDeps + V.length propDeps /= V.length vs) Nothing
Just (\x ->
case x of
(Object y) -> join $ (valSD <$> schemaDeps <*> pure y) <> (valPD <$> propDeps <*> pure y)
_ -> mempty)
where
toSchemaDep :: Spec -> Graph -> (Text, Value) -> Vector (Text, Schema)
toSchemaDep spc gr (t, Object o) = V.singleton (t, compile spc gr $ RawSchema (_rsURI s) o)
toSchemaDep _ _ _ = mempty
toPropDep :: (Text, Value) -> Vector (Text, Vector Text)
toPropDep (t, Array a) =
if V.length a <= 0
then mempty
else case traverse toTxt a of
Nothing -> mempty
Just ts ->
if allUnique ts
then V.singleton (t, ts)
else mempty
toPropDep _ = mempty
valSD :: (Text, Schema) -> HashMap Text Value -> Vector ValErr
valSD (t, sub) d =
case H.lookup t d of
Nothing -> mempty
Just _ -> validate sub (Object d)
valPD :: (Text, Vector Text) -> HashMap Text Value -> Vector ValErr
valPD (t, ts) d =
case H.lookup t d of
Nothing -> mempty
Just _ ->
case traverse ($ d) (H.lookup <$> ts) of
Nothing -> V.singleton
("Val error against property dependency with the key "
<> t <> " and the value " <> tshow ts <> " for: " <> tshow d)
Just _ -> mempty
dependencies _ _ _ _ = Nothing
enum :: ValidatorGen
enum _ _ _ (Array vs) = do
unless (V.length vs > 0 && allUnique vs) Nothing
Just (\x ->
if V.elem x vs
then mempty
else V.singleton $ tshow x <> " is not an element of enum " <> tshow vs)
enum _ _ _ _ = Nothing
typeVal :: ValidatorGen
typeVal _ _ _ (String val) = Just (\x -> isJsonType x (V.singleton val))
typeVal _ _ _ (Array vs) = do
ts <- traverse toTxt vs
unless (allUnique ts) Nothing
Just (`isJsonType` ts)
typeVal _ _ _ _ = Nothing
allOf :: ValidatorGen
allOf spec g s (Array vs) = do
os <- traverse toObj vs
let ss = compile spec g . RawSchema (_rsURI s) <$> os
Just (\x -> join $ validate <$> ss <*> pure x)
allOf _ _ _ _ = Nothing
anyOf :: ValidatorGen
anyOf spec g s (Array vs) = do
os <- traverse toObj vs
let ss = compile spec g . RawSchema (_rsURI s) <$> os
Just (\x ->
if V.elem V.empty (validate <$> ss <*> pure x)
then mempty
else V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x))
anyOf _ _ _ _ = Nothing
oneOf :: ValidatorGen
oneOf spec g s (Array vs) = do
os <- traverse toObj vs
let ss = compile spec g . RawSchema (_rsURI s) <$> os
Just (\x ->
if count V.empty (validate <$> ss <*> pure x) == 1
then mempty
else V.singleton ("Val error against oneOf " <> tshow vs <> " for: " <> tshow x))
oneOf _ _ _ _ = Nothing
notValidator :: ValidatorGen
notValidator spec g s (Object val) = do
let sub = compile spec g (RawSchema (_rsURI s) val)
Just (\x ->
if V.null $ validate sub x
then V.singleton ("Val error against not validator " <> tshow val <> " for: " <> tshow x)
else mempty)
notValidator _ _ _ _ = Nothing
ref :: ValidatorGen
ref spec g s (String val) = do
(reference, pointer) <- refAndPointer (_rsURI s `combineIdAndRef` val)
r <- RawSchema reference <$> H.lookup reference g
let p = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer
case jsonPointer p >>= resolvePointer (Object $ _rsObject r) of
Right (Object o) ->
Just $ validate $ compile spec g $ RawSchema (_rsURI r) o
_ -> Nothing
ref _ _ _ _ = Nothing
noVal :: ValidatorGen
noVal _ _ _ _ = Just (const V.empty)