module Data.Validator.Draft4 where
import Prelude
import Import
import Data.Aeson.Types (Parser)
import qualified Data.HashMap.Strict as HM
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes, isNothing,
maybe, maybeToList)
import Data.Scientific (Scientific)
import Data.Text (Text)
import qualified Data.Validator.Draft4.Any as AN
import qualified Data.Validator.Draft4.Array as AR
import qualified Data.Validator.Draft4.Number as NU
import qualified Data.Validator.Draft4.Object as OB
import qualified Data.Validator.Draft4.String as ST
import Data.Validator.Failure (Fail(..))
import Data.Validator.Types (Validator(..))
import Data.Validator.Utils (fromJSONEither)
run :: FromJSON b => (a -> b -> [c]) -> Maybe a -> Value -> [c]
run _ Nothing _ = mempty
run f (Just a) b =
case fromJSONEither b of
Left _ -> mempty
Right c -> f a c
noEmbedded :: a -> ([b], [b])
noEmbedded = const (mempty, mempty)
newtype MultipleOf
= MultipleOf { _unMultipleOf :: Scientific }
deriving (Eq, Show)
instance FromJSON MultipleOf where
parseJSON = withObject "MultipleOf" $ \o ->
MultipleOf <$> o .: "multipleOf"
multipleOf :: Validator a (Maybe MultipleOf) ()
multipleOf =
Validator
noEmbedded
(run (fmap maybeToList . NU.multipleOf . _unMultipleOf))
data MaximumContext
= MaximumContext Bool Scientific
deriving (Eq, Show)
instance FromJSON MaximumContext where
parseJSON = withObject "MaximumContext" $ \o -> MaximumContext
<$> o .:! "exclusiveMaximum" .!= False
<*> o .: "maximum"
maximumVal :: Validator a (Maybe MaximumContext) NU.MaximumInvalid
maximumVal =
Validator
noEmbedded
(run (\(MaximumContext a b) -> maybeToList . NU.maximumVal a b))
data MinimumContext
= MinimumContext Bool Scientific
deriving (Eq, Show)
instance FromJSON MinimumContext where
parseJSON = withObject "MinimumContext" $ \o -> MinimumContext
<$> o .:! "exclusiveMinimum" .!= False
<*> o .: "minimum"
minimumVal :: Validator a (Maybe MinimumContext) NU.MinimumInvalid
minimumVal =
Validator
noEmbedded
(run (\(MinimumContext a b) -> maybeToList . NU.minimumVal a b))
newtype MaxLength
= MaxLength { _unMaxLength :: Int }
deriving (Eq, Show)
instance FromJSON MaxLength where
parseJSON = withObject "MaxLength" $ \o ->
MaxLength <$> o .: "maxLength"
maxLength :: Validator a (Maybe MaxLength) ()
maxLength =
Validator
noEmbedded
(run (fmap maybeToList . ST.maxLength . _unMaxLength))
newtype MinLength
= MinLength { _unMinLength :: Int }
deriving (Eq, Show)
instance FromJSON MinLength where
parseJSON = withObject "MinLength" $ \o ->
MinLength <$> o .: "minLength"
minLength :: Validator a (Maybe MinLength) ()
minLength =
Validator
noEmbedded
(run (fmap maybeToList . ST.minLength . _unMinLength))
newtype PatternVal
= PatternVal { _unPatternVal :: Text }
deriving (Eq, Show)
instance FromJSON PatternVal where
parseJSON = withObject "PatternVal" $ \o ->
PatternVal <$> o .: "pattern"
patternVal :: Validator a (Maybe PatternVal) ()
patternVal =
Validator
noEmbedded
(run (fmap maybeToList . ST.patternVal . _unPatternVal))
newtype MaxItems
= MaxItems { _unMaxItems :: Int }
deriving (Eq, Show)
instance FromJSON MaxItems where
parseJSON = withObject "MaxItems" $ \o ->
MaxItems <$> o .: "maxItems"
maxItems :: Validator a (Maybe MaxItems) ()
maxItems =
Validator
noEmbedded
(run (fmap maybeToList . AR.maxItems . _unMaxItems))
newtype MinItems
= MinItems { _unMinItems :: Int }
deriving (Eq, Show)
instance FromJSON MinItems where
parseJSON = withObject "MinItems" $ \o ->
MinItems <$> o .: "minItems"
minItems :: Validator a (Maybe MinItems) ()
minItems =
Validator
noEmbedded
(run (fmap maybeToList . AR.minItems . _unMinItems))
newtype UniqueItems
= UniqueItems { _unUniqueItems :: Bool }
deriving (Eq, Show)
instance FromJSON UniqueItems where
parseJSON = withObject "UniqueItems" $ \o ->
UniqueItems <$> o .: "uniqueItems"
uniqueItems :: Validator a (Maybe UniqueItems) ()
uniqueItems =
Validator
noEmbedded
(run (fmap maybeToList . AR.uniqueItems . _unUniqueItems))
data ItemsContext schema =
ItemsContext
(Maybe (AR.AdditionalItems schema))
(AR.Items schema)
deriving (Eq, Show)
instance FromJSON schema => FromJSON (ItemsContext schema) where
parseJSON = withObject "ItemsContext" $ \o -> ItemsContext
<$> o .:! "additionalItems"
<*> o .: "items"
items
:: (schema -> Value -> [Fail err])
-> Validator schema (Maybe (ItemsContext schema)) (AR.ItemsInvalid err)
items f =
Validator
(\a -> case a of
Nothing -> mempty
Just (ItemsContext _ b) ->
case b of
AR.ItemsObject c -> (mempty, pure c)
AR.ItemsArray cs -> (mempty, cs))
(run (\(ItemsContext a b) -> AR.items f a b))
newtype AdditionalItemsContext schema
= AdditionalItemsContext
{ _unAdditionalItemsContext :: AR.AdditionalItems schema }
deriving (Eq, Show)
instance FromJSON schema => FromJSON (AdditionalItemsContext schema) where
parseJSON = withObject "AdditionalItemsContext" $ \o ->
AdditionalItemsContext <$> o .: "additionalItems"
additionalItemsEmbedded
:: Validator
schema
(Maybe (AdditionalItemsContext schema))
err
additionalItemsEmbedded=
Validator
(\a -> case a of
Just (AdditionalItemsContext (AR.AdditionalObject b)) ->
(mempty, pure b)
_ -> (mempty, mempty))
(const (const mempty))
newtype Definitions schema
= Definitions { _unDefinitions :: HashMap Text schema }
deriving (Eq, Show)
instance FromJSON schema => FromJSON (Definitions schema) where
parseJSON = withObject "Definitions" $ \o ->
Definitions <$> o .: "definitions"
definitionsEmbedded
:: Validator
schema
(Maybe (Definitions schema))
err
definitionsEmbedded =
Validator
(\a -> case a of
Just (Definitions b) -> (mempty, HM.elems b)
Nothing -> (mempty, mempty))
(const (const mempty))
newtype MaxProperties
= MaxProperties { _unMaxProperties :: Int }
deriving (Eq, Show)
instance FromJSON MaxProperties where
parseJSON = withObject "MaxProperties" $ \o ->
MaxProperties <$> o .: "maxProperties"
maxProperties :: Validator a (Maybe MaxProperties) ()
maxProperties =
Validator
noEmbedded
(run (fmap maybeToList . OB.maxProperties . _unMaxProperties))
newtype MinProperties
= MinProperties { _unMinProperties :: Int }
deriving (Eq, Show)
instance FromJSON MinProperties where
parseJSON = withObject "MinProperties" $ \o ->
MinProperties <$> o .: "minProperties"
minProperties :: Validator a (Maybe MinProperties) ()
minProperties =
Validator
noEmbedded
(run (fmap maybeToList . OB.minProperties . _unMinProperties))
newtype RequiredContext
= RequiredContext { _unRequiredContext :: OB.Required }
deriving (Eq, Show)
instance FromJSON RequiredContext where
parseJSON = withObject "RequiredContext" $ \o ->
RequiredContext <$> o .: "required"
required :: Validator a (Maybe RequiredContext) ()
required =
Validator
noEmbedded
(run (fmap maybeToList . OB.required . _unRequiredContext))
newtype DependenciesContext schema
= DependenciesContext
{ _unDependenciesContext :: HashMap Text (OB.Dependency schema) }
deriving (Eq, Show)
instance FromJSON schema => FromJSON (DependenciesContext schema) where
parseJSON = withObject "DependenciesContext" $ \o ->
DependenciesContext <$> o .: "dependencies"
dependencies
:: (schema -> Value -> [Fail err])
-> Validator
schema
(Maybe (DependenciesContext schema))
(OB.DependencyInvalid err)
dependencies f =
Validator
(maybe mempty ( (\a -> (mempty, a))
. catMaybes . fmap checkDependency
. HM.elems . _unDependenciesContext
))
(run (OB.dependencies f . _unDependenciesContext))
where
checkDependency :: OB.Dependency schema -> Maybe schema
checkDependency (OB.PropertyDependency _) = Nothing
checkDependency (OB.SchemaDependency s) = Just s
data PropertiesContext schema
= PropertiesContext
(Maybe (HashMap Text schema))
(Maybe (OB.AdditionalProperties schema))
(HashMap Text schema)
deriving (Eq, Show)
instance FromJSON schema => FromJSON (PropertiesContext schema) where
parseJSON = withObject "PropertiesContext" $ \o -> PropertiesContext
<$> o .:! "patternProperties"
<*> o .:! "additionalProperties"
<*> o .: "properties"
properties
:: (schema -> Value -> [Fail err])
-> Validator
schema
(Maybe (PropertiesContext schema))
(OB.PropertiesInvalid err)
properties f =
Validator
(\a -> case a of
Just (PropertiesContext _ _ b) -> (mempty, HM.elems b)
Nothing -> (mempty, mempty))
(run (\(PropertiesContext a b c) -> OB.properties f a b c))
data PatternPropertiesContext schema
= PatternPropertiesContext
Bool
(Maybe (OB.AdditionalProperties schema))
(HashMap Text schema)
deriving (Eq, Show)
instance FromJSON schema => FromJSON (PatternPropertiesContext schema) where
parseJSON = withObject "PatternPropertiesContext" $ \o ->
PatternPropertiesContext
<$> shouldRun o
<*> o .:! "additionalProperties"
<*> o .: "patternProperties"
where
shouldRun :: HashMap Text Value -> Parser Bool
shouldRun o = do
a <- o .:! "properties"
pure $ isNothing (a :: Maybe (HashMap Text schema))
patternProperties
:: (schema -> Value -> [Fail err])
-> Validator
schema
(Maybe (PatternPropertiesContext schema))
(OB.PatternPropertiesInvalid err)
patternProperties f =
Validator
(\a -> case a of
Just (PatternPropertiesContext _ _ b) -> (mempty, HM.elems b)
Nothing -> (mempty, mempty))
(run (\(PatternPropertiesContext a b c) -> OB.patternProperties f a b c))
data AdditionalPropertiesContext schema
= AdditionalPropertiesContext
Bool
(OB.AdditionalProperties schema)
deriving (Eq, Show)
instance FromJSON schema => FromJSON (AdditionalPropertiesContext schema) where
parseJSON = withObject "AdditionalPropertiesContext" $ \o ->
AdditionalPropertiesContext
<$> shouldRun o
<*> o .: "additionalProperties"
where
shouldRun :: HashMap Text Value -> Parser Bool
shouldRun o = do
a <- o .:! "properties"
b <- o .:! "patternProperties"
pure $ isNothing (a :: Maybe (HashMap Text schema))
&& isNothing (b :: Maybe (HashMap Text schema))
additionalProperties
:: (schema -> Value -> [Fail err])
-> Validator
schema
(Maybe (AdditionalPropertiesContext schema))
(OB.AdditionalPropertiesInvalid err)
additionalProperties f =
Validator
(\a -> case a of
Nothing -> mempty
Just (AdditionalPropertiesContext _ b) ->
case b of
OB.AdditionalPropertiesBool _ -> (mempty, mempty)
OB.AdditionalPropertiesObject c -> (mempty, pure c))
(run (\(AdditionalPropertiesContext a b) -> OB.additionalProperties f a b))
newtype Ref
= Ref { _unRef :: Text }
deriving (Eq, Show)
instance FromJSON Ref where
parseJSON = withObject "Ref" $ \o ->
Ref <$> o .: "$ref"
ref
:: (FromJSON schema, ToJSON schema)
=> AN.VisitedSchemas
-> Maybe Text
-> (Maybe Text -> Maybe schema)
-> (AN.VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err])
-> Validator a (Maybe Ref) (AN.RefInvalid err)
ref visited scope getRef f =
Validator
noEmbedded
(run (AN.ref visited scope getRef f . _unRef))
newtype EnumContext
= EnumContext { _unEnumContext :: AN.EnumVal }
deriving (Eq, Show)
instance FromJSON EnumContext where
parseJSON = withObject "EnumContext" $ \o ->
EnumContext <$> o .: "enum"
enumVal :: Validator a (Maybe EnumContext) ()
enumVal =
Validator
noEmbedded
(run (fmap maybeToList . AN.enumVal . _unEnumContext))
newtype TypeContext
= TypeContext { _unTypeContext :: AN.TypeVal }
deriving (Eq, Show)
instance FromJSON TypeContext where
parseJSON = withObject "TypeContext" $ \o ->
TypeContext <$> o .: "type"
typeVal :: Validator a (Maybe TypeContext) ()
typeVal =
Validator
noEmbedded
(run (fmap maybeToList . AN.typeVal . _unTypeContext))
newtype AllOf schema
= AllOf { _unAllOf :: NonEmpty schema }
deriving (Eq, Show)
instance FromJSON schema => FromJSON (AllOf schema) where
parseJSON = withObject "AllOf" $ \o ->
AllOf <$> o .: "allOf"
allOf
:: (schema -> Value -> [Fail err])
-> Validator schema (Maybe (AllOf schema)) err
allOf f =
Validator
(\a -> case a of
Just (AllOf b) -> (NE.toList b, mempty)
Nothing -> (mempty, mempty))
(run (AN.allOf f . _unAllOf))
newtype AnyOf schema
= AnyOf { _unAnyOf :: NonEmpty schema }
deriving (Eq, Show)
instance FromJSON schema => FromJSON (AnyOf schema) where
parseJSON = withObject "AnyOf" $ \o ->
AnyOf <$> o .: "anyOf"
anyOf
:: ToJSON schema
=> (schema -> Value -> [Fail err])
-> Validator schema (Maybe (AnyOf schema)) ()
anyOf f =
Validator
(\a -> case a of
Just (AnyOf b) -> (NE.toList b, mempty)
Nothing -> (mempty, mempty))
(run (fmap maybeToList . AN.anyOf f . _unAnyOf))
newtype OneOf schema
= OneOf { _unOneOf :: NonEmpty schema }
deriving (Eq, Show)
instance FromJSON schema => FromJSON (OneOf schema) where
parseJSON = withObject "OneOf" $ \o ->
OneOf <$> o .: "oneOf"
oneOf
:: ToJSON schema
=> (schema -> Value -> [Fail err])
-> Validator schema (Maybe (OneOf schema)) ()
oneOf f =
Validator
(\a -> case a of
Just (OneOf b) -> (NE.toList b, mempty)
Nothing -> (mempty, mempty))
(run (fmap maybeToList . AN.oneOf f . _unOneOf))
newtype NotVal schema
= NotVal { _unNotVal :: schema }
deriving (Eq, Show)
instance FromJSON schema => FromJSON (NotVal schema) where
parseJSON = withObject "NotVal" $ \o ->
NotVal <$> o .: "not"
notVal
:: ToJSON schema
=> (schema -> Value -> [Fail err])
-> Validator schema (Maybe (NotVal schema)) ()
notVal f =
Validator
(\a -> case a of
Just (NotVal b) -> (pure b, mempty)
Nothing -> (mempty, mempty))
(run (fmap maybeToList . AN.notVal f . _unNotVal))