module Data.Validator.Draft4.Any where
import Import
import Prelude hiding (any, concat, elem)
import Control.Monad
import Data.Aeson.Types (Parser)
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import qualified Data.Scientific as SCI
import Data.Set (Set)
import qualified Data.Set as S
import Data.Validator.Failure (Fail(..))
import qualified Data.Validator.Utils as UT
import Data.Validator.Reference (URIBaseAndFragment,
resolveFragment, resolveReference)
data RefInvalid err
= RefResolution
| RefLoop
| RefInvalid err
deriving (Eq, Show)
newtype VisitedSchemas
= VisitedSchemas { _unVisited :: [URIBaseAndFragment] }
deriving (Eq, Show, Monoid)
ref
:: forall err schema. (FromJSON schema, ToJSON schema)
=> VisitedSchemas
-> Maybe Text
-> (Maybe Text -> Maybe schema)
-> (VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err])
-> Text
-> Value
-> [Fail (RefInvalid err)]
ref visited scope getRef f reference x
| (mUri, mFragment) `elem` _unVisited visited =
pure $ Failure RefLoop (toJSON reference) mempty x
| otherwise =
case getRef mUri of
Nothing -> pure failureDNE
Just schema ->
case resolveFragment mFragment schema of
Nothing -> pure failureDNE
Just s ->
let newVisited = (VisitedSchemas [(mUri, mFragment)]
<> visited)
in fmap RefInvalid <$> f newVisited mUri s x
where
(mUri, mFragment) = resolveReference scope reference
failureDNE :: Fail (RefInvalid err)
failureDNE = Failure RefResolution (toJSON reference) mempty x
newtype EnumVal
= EnumVal { _unEnumVal :: NonEmpty Value }
deriving (Eq, Show)
instance FromJSON EnumVal where
parseJSON v = checkUnique . UT._unNonEmpty' =<< parseJSON v
where
checkUnique :: NonEmpty Value -> Parser EnumVal
checkUnique a
| UT.allUniqueValues' a = pure (EnumVal a)
| otherwise = fail "All elements of the Enum validator must be unique."
instance ToJSON EnumVal where
toJSON = toJSON . UT.NonEmpty' . _unEnumVal
instance Arbitrary EnumVal where
arbitrary = do
xs <- (fmap.fmap) UT._unArbitraryValue arbitrary
case NE.nonEmpty (toUnique xs) of
Nothing -> EnumVal . pure . UT._unArbitraryValue <$> arbitrary
Just ne -> pure (EnumVal ne)
where
toUnique :: [Value] -> [Value]
toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue
enumVal :: EnumVal -> Value -> Maybe (Fail ())
enumVal (EnumVal vs) x
| not (UT.allUniqueValues' vs) = Nothing
| x `elem` vs = Nothing
| otherwise = Just $ Failure () (toJSON (UT.NonEmpty' vs))
mempty x
data TypeVal
= TypeValString Text
| TypeValArray (Set Text)
deriving (Eq, Show)
instance FromJSON TypeVal where
parseJSON v = fmap TypeValString (parseJSON v)
<|> fmap TypeValArray (parseJSON v)
instance ToJSON TypeVal where
toJSON (TypeValString t) = toJSON t
toJSON (TypeValArray ts) = toJSON ts
instance Arbitrary TypeVal where
arbitrary = oneof [ TypeValString <$> UT.arbitraryText
, TypeValArray <$> UT.arbitrarySetOfText
]
setFromTypeVal :: TypeVal -> Set Text
setFromTypeVal (TypeValString t) = S.singleton t
setFromTypeVal (TypeValArray ts) = ts
typeVal :: TypeVal -> Value -> Maybe (Fail ())
typeVal tv x
| S.null matches = Just (Failure () (toJSON tv) mempty x)
| otherwise = Nothing
where
matches :: Set Text
matches = S.intersection okTypes (setFromTypeVal tv)
okTypes :: Set Text
okTypes =
case x of
Null -> S.singleton "null"
(Array _) -> S.singleton "array"
(Bool _) -> S.singleton "boolean"
(Object _) -> S.singleton "object"
(String _) -> S.singleton "string"
(Number y) ->
if SCI.isInteger y
then S.fromList ["number", "integer"]
else S.singleton "number"
allOf
:: (schema -> Value -> [Fail err])
-> NonEmpty schema
-> Value
-> [Fail err]
allOf f subSchemas x = NE.toList subSchemas >>= flip f x
anyOf
:: forall err schema.
(schema -> Value -> [Fail err])
-> NonEmpty schema
-> Value
-> [Fail err]
anyOf f subSchemas x
| any null results = mempty
| otherwise = concat results
where
results :: [[Fail err]]
results = flip f x <$> NE.toList subSchemas
data OneOfInvalid err
= TooManySuccesses
| NoSuccesses err
deriving (Eq, Show)
oneOf
:: forall err schema. ToJSON schema
=> (schema -> Value -> [Fail err])
-> NonEmpty schema
-> Value
-> [Fail (OneOfInvalid err)]
oneOf f subSchemas x
| length successes == 1 = mempty
| length successes > 1 = pure tooManySuccesses
| otherwise = fmap NoSuccesses <$> concat failures
where
(successes, failures) = partition null results
results :: [[Fail err]]
results = flip f x <$> NE.toList subSchemas
tooManySuccesses :: Fail (OneOfInvalid err)
tooManySuccesses = Failure TooManySuccesses
(toJSON (UT.NonEmpty' subSchemas)) mempty x
notVal
:: ToJSON schema
=> (schema -> Value -> [Fail err])
-> schema
-> Value
-> Maybe (Fail ())
notVal f schema x =
case f schema x of
[] -> Just (Failure () (toJSON schema) mempty x)
_ -> Nothing