module Data.Validator.Draft4.Object.Properties where
import Import
import Prelude
import Control.Monad
import qualified Data.Aeson.Pointer as AP
import Data.Functor (($>))
import qualified Data.HashMap.Strict as HM
import Data.Text.Encoding (encodeUtf8)
import qualified Text.Regex.PCRE.Heavy as RE
import Data.Validator.Failure (Fail(..), prependToPath)
newtype Remaining
= Remaining { _unRemaining :: HashMap Text Value }
data PropertiesInvalid err
= PropertiesInvalid err
| PropPatternInvalid err
| PropAdditionalInvalid (AdditionalPropertiesInvalid err)
deriving (Eq, Show)
properties
:: forall err schema.
(schema -> Value -> [Fail err])
-> Maybe (HashMap Text schema)
-> Maybe (AdditionalProperties schema)
-> HashMap Text schema
-> HashMap Text Value
-> [Fail (PropertiesInvalid err)]
properties f mPat mAdd propertiesHm x =
fmap (fmap PropertiesInvalid) propFailures
<> fmap (fmap PropPatternInvalid) patternFailures
<> fmap (fmap PropAdditionalInvalid) additionalFailures
where
propertiesAndUnmatched :: ([Fail err], Remaining)
propertiesAndUnmatched = ( failures
, Remaining (HM.difference x propertiesHm)
)
where
failures :: [Fail err]
failures = HM.toList (HM.intersectionWith f propertiesHm x)
>>= (\(k,vs) -> fmap (prependToPath (AP.Token k)) vs)
(propFailures, remaining1) = propertiesAndUnmatched
mPatProp :: Maybe (HashMap Text Value -> ([Fail err], Remaining))
mPatProp = patternAndUnmatched f <$> mPat
patternFailures :: [Fail err]
patternFailures = case mPatProp of
Nothing -> mempty
Just val -> fst (val x)
remaining2 :: Remaining
remaining2 = case mPatProp of
Nothing -> remaining1
Just val -> snd . val . _unRemaining $ remaining1
additionalFailures :: [Fail (AdditionalPropertiesInvalid err)]
additionalFailures =
case mAdd of
Nothing -> mempty
Just a -> additionalProperties f True a (_unRemaining remaining2)
data PatternPropertiesInvalid err
= PPInvalid err
| PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err)
deriving (Eq, Show)
patternProperties
:: forall err schema.
(schema -> Value -> [Fail err])
-> Bool
-> Maybe (AdditionalProperties schema)
-> HashMap Text schema
-> HashMap Text Value
-> [Fail (PatternPropertiesInvalid err)]
patternProperties _ False _ _ _ = mempty
patternProperties f _ mAdd patternPropertiesHm x =
(fmap PPInvalid <$> ppFailures)
<> (fmap PPAdditionalPropertiesInvalid <$> addFailures)
where
patternProps :: ([Fail err], Remaining)
patternProps = patternAndUnmatched f patternPropertiesHm x
(ppFailures, remaining) = patternProps
addFailures :: [Fail (AdditionalPropertiesInvalid err)]
addFailures =
case mAdd of
Nothing -> mempty
Just a -> additionalProperties f True a (_unRemaining remaining)
patternAndUnmatched
:: forall err schema.
(schema -> Value -> [Fail err])
-> HashMap Text schema
-> HashMap Text Value
-> ([Fail err], Remaining)
patternAndUnmatched f patPropertiesHm x =
(HM.foldlWithKey' runVals mempty perhapsMatches, remaining)
where
perhapsMatches :: HashMap Text (Value, [schema])
perhapsMatches = HM.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x
where
matchingSchemas
:: HashMap Text schema
-> HashMap Text (Value, [schema])
-> Text
-> Value
-> HashMap Text (Value, [schema])
matchingSchemas subSchemas acc k v =
HM.insert k (v, HM.foldlWithKey' (checkKey k) mempty subSchemas) acc
checkKey
:: Text
-> [schema]
-> Text
-> schema
-> [schema]
checkKey k acc r subSchema =
case RE.compileM (encodeUtf8 r) mempty of
Left _ -> acc
Right re -> if k RE.=~ re
then pure subSchema <> acc
else acc
runVals
:: [Fail err]
-> Text
-> (Value, [schema])
-> [Fail err]
runVals acc k (v,subSchemas) =
(subSchemas >>= (\schema -> prependToPath (AP.Token k) <$> f schema v))
<> acc
remaining :: Remaining
remaining = Remaining . fmap fst . HM.filter (null . snd) $ perhapsMatches
data AdditionalProperties schema
= AdditionalPropertiesBool Bool
| AdditionalPropertiesObject schema
deriving (Eq, Show)
instance FromJSON schema => FromJSON (AdditionalProperties schema) where
parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)
<|> fmap AdditionalPropertiesObject (parseJSON v)
instance ToJSON schema => ToJSON (AdditionalProperties schema) where
toJSON (AdditionalPropertiesBool b) = toJSON b
toJSON (AdditionalPropertiesObject hm) = toJSON hm
instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where
arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary
, AdditionalPropertiesObject <$> arbitrary
]
data AdditionalPropertiesInvalid err
= APBoolInvalid
| APObjectInvalid err
deriving (Eq, Show)
additionalProperties
:: forall err schema.
(schema -> Value -> [Fail err])
-> Bool
-> AdditionalProperties schema
-> HashMap Text Value
-> [Fail (AdditionalPropertiesInvalid err)]
additionalProperties _ False _ _ = mempty
additionalProperties f _ a x =
case a of
AdditionalPropertiesBool b ->
($> APBoolInvalid) <$> additionalPropertiesBool b x
AdditionalPropertiesObject b ->
fmap APObjectInvalid <$> additionalPropertiesObject f b x
additionalPropertiesBool
:: Bool
-> HashMap Text Value
-> [Fail ()]
additionalPropertiesBool False x
| HM.size x > 0 = pure $ Failure () (Bool False) mempty (Object x)
| otherwise = mempty
additionalPropertiesBool True _ = mempty
additionalPropertiesObject
:: forall err schema.
(schema -> Value -> [Fail err])
-> schema
-> HashMap Text Value
-> [Fail err]
additionalPropertiesObject f schema x = HM.toList x >>= g
where
g :: (Text, Value) -> [Fail err]
g (k,v) = prependToPath (AP.Token k) <$> f schema v