module Data.JsonSchema.Draft4.Arrays where
import Control.Monad
import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
import Data.JsonSchema.Core
import Data.JsonSchema.Helpers
import Import
data ItemsFailure err = Items err | AdditionalItemsBool | AdditionalItemsObject err
items :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]
items spec g s (Object o) =
let subSchema = compile spec g (RawSchema (_rsURI s) o)
in Just $ \x ->
case x of
Array ys -> V.toList ys >>= fmap (modifyFailureName Items) . validate subSchema
_ -> mempty
items spec g s (Array vs) = do
os <- traverse toObj vs
let subSchemas = compile spec g . RawSchema (_rsURI s) <$> V.toList os
mAdditionalItems = additionalItems spec g s =<< H.lookup "additionalItems" (_rsObject s)
Just $ \x ->
case x of
Array ys ->
let extras = V.drop (V.length os) ys
itemFailures = join $ fmap (modifyFailureName Items) <$> zipWith validate subSchemas (V.toList ys)
additionalItemFailures = runMaybeVal mAdditionalItems (Array extras)
in itemFailures <> additionalItemFailures
_ -> mempty
items _ _ _ _ = Nothing
additionalItems :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]
additionalItems _ _ _ val@(Bool v) =
Just $ \x ->
case x of
Array ys ->
if not v && V.length ys > 0
then pure $ ValidationFailure AdditionalItemsBool (FailureInfo val x)
else mempty
_ -> mempty
additionalItems spec g s (Object o) =
let subSchema = compile spec g (RawSchema (_rsURI s) o)
in Just $ \x ->
case x of
Array ys -> V.toList ys >>= fmap (modifyFailureName AdditionalItemsObject) . validate subSchema
_ -> mempty
additionalItems _ _ _ _ = Nothing
maxItems :: ValidatorConstructor err [FailureInfo]
maxItems _ _ _ val = do
n <- fromJSONInt val
greaterThanZero n
Just $ \x ->
case x of
Array ys ->
if V.length ys > n
then pure (FailureInfo val x)
else mempty
_ -> mempty
minItems :: ValidatorConstructor err [FailureInfo]
minItems _ _ _ val = do
n <- fromJSONInt val
greaterThanZero n
Just $ \x ->
case x of
Array ys ->
if V.length ys < n
then pure (FailureInfo val x)
else mempty
_ -> mempty
uniqueItems :: ValidatorConstructor err [FailureInfo]
uniqueItems _ _ _ val@(Bool v) = do
unless v Nothing
Just $ \x ->
case x of
(Array ys) -> if allUniqueValues ys
then mempty
else pure (FailureInfo val x)
_ -> mempty
uniqueItems _ _ _ _ = Nothing