module Data.Validator.Draft4.Array where
import Import
import Prelude
import Control.Monad
import qualified Data.Aeson.Pointer as AP
import qualified Data.Text as T
import qualified Data.Vector as V
import Text.Read (readMaybe)
import Data.Validator.Failure (Fail(..), prependToPath)
import Data.Validator.Utils (allUniqueValues)
maxItems :: Int -> Vector Value -> Maybe (Fail ())
maxItems n xs
| n < 0 = Nothing
| V.length xs > n = Just (Failure () (toJSON n) mempty (Array xs))
| otherwise = Nothing
minItems :: Int -> Vector Value -> Maybe (Fail ())
minItems n xs
| n < 0 = Nothing
| V.length xs < n = Just (Failure () (toJSON n) mempty (Array xs))
| otherwise = Nothing
uniqueItems :: Bool -> Vector Value -> Maybe (Fail ())
uniqueItems True xs
| allUniqueValues xs = Nothing
| otherwise = Just (Failure () (Bool True) mempty (Array xs))
uniqueItems False _ = Nothing
data Items schema
= ItemsObject schema
| ItemsArray [schema]
deriving (Eq, Show)
instance FromJSON schema => FromJSON (Items schema) where
parseJSON v = fmap ItemsObject (parseJSON v)
<|> fmap ItemsArray (parseJSON v)
instance ToJSON schema => ToJSON (Items schema) where
toJSON (ItemsObject hm) = toJSON hm
toJSON (ItemsArray schemas) = toJSON schemas
instance Arbitrary schema => Arbitrary (Items schema) where
arbitrary = oneof [ ItemsObject <$> arbitrary
, ItemsArray <$> arbitrary
]
data ItemsInvalid err
= Items err
| AdditionalItemsBoolInvalid
| AdditionalItemsObjectInvalid err
deriving (Eq, Show)
items
:: forall err schema.
(schema -> Value -> [Fail err])
-> Maybe (AdditionalItems schema)
-> Items schema
-> Vector Value
-> [Fail (ItemsInvalid err)]
items f _ (ItemsObject subSchema) xs =
zip [0..] (V.toList xs) >>= g
where
g :: (Int, Value) -> [Fail (ItemsInvalid err)]
g (index,x) = fmap Items
. prependToPath (AP.Token (T.pack (show index)))
<$> f subSchema x
items f mAdditional (ItemsArray subSchemas) xs =
itemFailures <> additionalItemFailures
where
indexedValues :: [(Int, Value)]
indexedValues = zip [0..] (V.toList xs)
itemFailures :: [Fail (ItemsInvalid err)]
itemFailures = join (zipWith g subSchemas indexedValues)
where
g :: schema -> (Int, Value) -> [Fail (ItemsInvalid err)]
g schema (index,x) = fmap Items
. prependToPath (AP.Token (T.pack (show index)))
<$> f schema x
additionalItemFailures :: [Fail (ItemsInvalid err)]
additionalItemFailures =
case mAdditional of
Nothing -> mempty
Just adi -> fmap correctName
. correctIndexes
<$> additionalItems f adi extras
where
extras :: Vector Value
extras = V.fromList . fmap snd
. drop (length subSchemas) $ indexedValues
correctIndexes
:: Fail (AdditionalItemsInvalid err)
-> Fail (AdditionalItemsInvalid err)
correctIndexes (Failure a b c d) = Failure a b (fixIndex c) d
where
fixIndex :: AP.Pointer -> AP.Pointer
fixIndex (AP.Pointer (tok:toks)) =
case readMaybe . T.unpack . AP._unToken $ tok of
Nothing -> AP.Pointer $ tok:toks
Just n -> AP.Pointer $
(AP.Token . T.pack . show $ n + length subSchemas):toks
fixIndex (AP.Pointer []) = AP.Pointer []
correctName :: AdditionalItemsInvalid err -> ItemsInvalid err
correctName AdditionalBoolInvalid = AdditionalItemsBoolInvalid
correctName (AdditionalObjectInvalid err) =
AdditionalItemsObjectInvalid err
data AdditionalItems schema
= AdditionalBool Bool
| AdditionalObject schema
deriving (Eq, Show)
instance FromJSON schema => FromJSON (AdditionalItems schema) where
parseJSON v = fmap AdditionalBool (parseJSON v)
<|> fmap AdditionalObject (parseJSON v)
instance ToJSON schema => ToJSON (AdditionalItems schema) where
toJSON (AdditionalBool b) = toJSON b
toJSON (AdditionalObject hm) = toJSON hm
instance Arbitrary schema => Arbitrary (AdditionalItems schema) where
arbitrary = oneof [ AdditionalBool <$> arbitrary
, AdditionalObject <$> arbitrary
]
data AdditionalItemsInvalid err
= AdditionalBoolInvalid
| AdditionalObjectInvalid err
deriving (Eq, Show)
additionalItems
:: forall err schema.
(schema -> Value -> [Fail err])
-> AdditionalItems schema
-> Vector Value
-> [Fail (AdditionalItemsInvalid err)]
additionalItems _ (AdditionalBool b) xs
| b = mempty
| V.length xs > 0 = pure (Failure AdditionalBoolInvalid (Bool b)
mempty (toJSON xs))
| otherwise = mempty
additionalItems f (AdditionalObject subSchema) xs =
zip [0..] (V.toList xs) >>= g
where
g :: (Int, Value) -> [Fail (AdditionalItemsInvalid err)]
g (index,x) = fmap AdditionalObjectInvalid
. prependToPath (AP.Token (T.pack (show index)))
<$> f subSchema x