hjsonschema-1.2.0.0: src/Data/Validator/Draft4/Any.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Validator.Draft4.Any where
import Import
-- Hiding is for GHCs before 7.10:
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)
--------------------------------------------------
-- * $ref
--------------------------------------------------
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
--------------------------------------------------
-- * enum
--------------------------------------------------
-- | From the spec:
-- <http://json-schema.org/latest/json-schema-validation.html#anchor76>
--
-- > The value of this keyword MUST be an array.
-- > This array MUST have at least one element.
-- > Elements in the array MUST be unique.
--
-- NOTE: We don't enforce the uniqueness constraint in the haskell code,
-- but we do in the 'FromJSON' instance.
newtype EnumVal
= EnumVal { _unEnumVal :: NonEmpty Value }
-- Given a choice, we'd prefer to enforce uniqueness through the type
-- system over having at least one element. To use a 'Set' though we'd
-- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)
-- and we'd rather not make users mess with 'OrdValue'.
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
--------------------------------------------------
-- * type
--------------------------------------------------
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
-- There can be more than one match because a 'Value' can be both a
-- @"number"@ and an @"integer"@.
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
--------------------------------------------------
allOf
:: (schema -> Value -> [Fail err])
-> NonEmpty schema
-> Value
-> [Fail err]
allOf f subSchemas x = NE.toList subSchemas >>= flip f x
--------------------------------------------------
-- * anyOf
--------------------------------------------------
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
--------------------------------------------------
-- * oneOf
--------------------------------------------------
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
-- NOTE: This could also return information about the specific
-- validators that succeeded.
tooManySuccesses :: Fail (OneOfInvalid err)
tooManySuccesses = Failure TooManySuccesses
(toJSON (UT.NonEmpty' subSchemas)) mempty x
--------------------------------------------------
-- * not
--------------------------------------------------
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