@@ -1,38 +1,36 @@
1-- | Turn the validation functions into actual 'Validator's.
1-- | Turn the validation functions into actual 'Validator's.
3−-- From this point on they know how to parse themselves from JSON
4−-- and also know how to extract subschemas embedded within themselves.
6−module Data.Validator.Draft4 where
3+module Data.Validator.Draft4
4+ ( module Data.Validator.Draft4
9import Import
8import Import
11−import Data.Aeson.Types (Parser)
12import qualified Data.HashMap.Strict as HM
10import qualified Data.HashMap.Strict as HM
13−import Data.List.NonEmpty (NonEmpty)
14import qualified Data.List.NonEmpty as NE
11import qualified Data.List.NonEmpty as NE
15−import Data.Maybe (catMaybes, isNothing,
12+import Data.Maybe (catMaybes, maybe, maybeToList)
17−import Data.Scientific (Scientific)
18import Data.Text (Text)
13import Data.Text (Text)
20−import qualified Data.Validator.Draft4.Any as AN
15+import Data.Validator.Draft4.Any as Export
21−import qualified Data.Validator.Draft4.Array as AR
16+import Data.Validator.Draft4.Array as Export
22−import qualified Data.Validator.Draft4.Number as NU
17+import Data.Validator.Draft4.Number as Export
23−import qualified Data.Validator.Draft4.Object as OB
18+import Data.Validator.Draft4.Object as Export
24−import qualified Data.Validator.Draft4.String as ST
19+import Data.Validator.Draft4.String as Export
25−import Data.Validator.Failure (Fail(..))
26import Data.Validator.Types (Validator(..))
20import Data.Validator.Types (Validator(..))
27import Data.Validator.Utils (fromJSONEither)
21import Data.Validator.Utils (fromJSONEither)
29-- | For internal use.
23-- | For internal use.
25+-- Take a validation function, a possibly existing validator, and some data.
26+-- If the validator is exists and can validate the type of data we have,
27+-- attempt to do so and return any failures.
30−run :: FromJSON b => (a -> b -> [c]) -> Maybe a -> Value -> [c]
28+run :: FromJSON b => (a -> b -> Maybe c) -> Maybe a -> Value -> [c]
31run _ Nothing _ = mempty
29run _ Nothing _ = mempty
32run f (Just a) b =
30run f (Just a) b =
33 case fromJSONEither b of
31 case fromJSONEither b of
34 Left _ -> mempty
32 Left _ -> mempty
35− Right c -> f a c
33+ Right c -> maybeToList (f a c)
37-- | For internal use.
35-- | For internal use.
38noEmbedded :: a -> ([b], [b])
36noEmbedded :: a -> ([b], [b])
@@ -42,190 +40,116 @@ noEmbedded = const (mempty, mempty)
42-- * Numbers
40-- * Numbers
43--------------------------------------------------
41--------------------------------------------------
46− = MultipleOf { _unMultipleOf :: Scientific }
49−instance FromJSON MultipleOf where
50− parseJSON = withObject "MultipleOf" $ \o ->
51− MultipleOf <$> o .: "multipleOf"
53−multipleOf :: Validator a (Maybe MultipleOf) ()
43+multipleOfValidator :: Validator a (Maybe MultipleOf) MultipleOfInvalid
54−multipleOf =
44+multipleOfValidator = Validator noEmbedded (run multipleOfVal)
57− (run (fmap maybeToList . NU.multipleOf . _unMultipleOf))
59−data MaximumContext
46+maximumValidator :: Validator a (Maybe Maximum) MaximumInvalid
60− = MaximumContext Bool Scientific
47+maximumValidator = Validator noEmbedded (run maximumVal)
63−instance FromJSON MaximumContext where
64− parseJSON = withObject "MaximumContext" $ \o -> MaximumContext
65− <$> o .:! "exclusiveMaximum" .!= False
68−maximumVal :: Validator a (Maybe MaximumContext) NU.MaximumInvalid
72− (run (\(MaximumContext a b) -> maybeToList . NU.maximumVal a b))
75− = MinimumContext Bool Scientific
78−instance FromJSON MinimumContext where
79− parseJSON = withObject "MinimumContext" $ \o -> MinimumContext
80− <$> o .:! "exclusiveMinimum" .!= False
83−minimumVal :: Validator a (Maybe MinimumContext) NU.MinimumInvalid
49+minimumValidator :: Validator a (Maybe Minimum) MinimumInvalid
84−minimumVal =
50+minimumValidator = Validator noEmbedded (run minimumVal)
87− (run (\(MinimumContext a b) -> maybeToList . NU.minimumVal a b))
89--------------------------------------------------
52--------------------------------------------------
90-- * Strings
53-- * Strings
91--------------------------------------------------
54--------------------------------------------------
93−newtype MaxLength
56+maxLengthValidator :: Validator a (Maybe MaxLength) MaxLengthInvalid
94− = MaxLength { _unMaxLength :: Int }
57+maxLengthValidator = Validator noEmbedded (run maxLengthVal)
97−instance FromJSON MaxLength where
59+minLengthValidator :: Validator a (Maybe MinLength) MinLengthInvalid
98− parseJSON = withObject "MaxLength" $ \o ->
60+minLengthValidator = Validator noEmbedded (run minLengthVal)
99− MaxLength <$> o .: "maxLength"
101−maxLength :: Validator a (Maybe MaxLength) ()
62+patternValidator :: Validator a (Maybe PatternValidator) PatternInvalid
102−maxLength =
63+patternValidator = Validator noEmbedded (run patternVal)
105− (run (fmap maybeToList . ST.maxLength . _unMaxLength))
108− = MinLength { _unMinLength :: Int }
111−instance FromJSON MinLength where
112− parseJSON = withObject "MinLength" $ \o ->
113− MinLength <$> o .: "minLength"
115−minLength :: Validator a (Maybe MinLength) ()
119− (run (fmap maybeToList . ST.minLength . _unMinLength))
122− = PatternVal { _unPatternVal :: Text }
125−instance FromJSON PatternVal where
126− parseJSON = withObject "PatternVal" $ \o ->
127− PatternVal <$> o .: "pattern"
129−patternVal :: Validator a (Maybe PatternVal) ()
133− (run (fmap maybeToList . ST.patternVal . _unPatternVal))
135--------------------------------------------------
65--------------------------------------------------
136-- * Arrays
66-- * Arrays
137--------------------------------------------------
67--------------------------------------------------
139−newtype MaxItems
69+maxItemsValidator :: Validator a (Maybe MaxItems) MaxItemsInvalid
140− = MaxItems { _unMaxItems :: Int }
70+maxItemsValidator = Validator noEmbedded (run maxItemsVal)
141− deriving (Eq, Show)
71+
142−
72+minItemsValidator :: Validator a (Maybe MinItems) MinItemsInvalid
143−instance FromJSON MaxItems where
73+minItemsValidator = Validator noEmbedded (run minItemsVal)
144− parseJSON = withObject "MaxItems" $ \o ->
74+
145− MaxItems <$> o .: "maxItems"
75+uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid
146−
76+uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal)
147−maxItems :: Validator a (Maybe MaxItems) ()
77+
148−maxItems =
78+itemsRelatedValidator
149− Validator
79+ :: (schema -> Value -> [err])
150− noEmbedded
80+ -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err)
151− (run (fmap maybeToList . AR.maxItems . _unMaxItems))
81+itemsRelatedValidator f =
153−newtype MinItems
83+ (\a -> ( mempty
154− = MinItems { _unMinItems :: Int }
84+ , case _irItems a of
155− deriving (Eq, Show)
85+ Just (ItemsObject b) -> pure b
156−
86+ Just (ItemsArray cs) -> cs
157−instance FromJSON MinItems where
87+ Nothing -> mempty
158− parseJSON = withObject "MinItems" $ \o ->
88+ <> case _irAdditional a of
159− MinItems <$> o .: "minItems"
89+ Just (AdditionalObject b) -> pure b
161−minItems :: Validator a (Maybe MinItems) ()
91+ ))
162−minItems =
92+ (\a b -> case fromJSONEither b of
163− Validator
93+ Left _ -> mempty
164− noEmbedded
94+ Right c -> itemsRelatedVal f a c)
165− (run (fmap maybeToList . AR.minItems . _unMinItems))
168− = UniqueItems { _unUniqueItems :: Bool }
171−instance FromJSON UniqueItems where
96+--------------------------------------------------
172− parseJSON = withObject "UniqueItems" $ \o ->
97+-- * Objects
173− UniqueItems <$> o .: "uniqueItems"
98+--------------------------------------------------
175−uniqueItems :: Validator a (Maybe UniqueItems) ()
100+maxPropertiesValidator
176−uniqueItems =
101+ :: Validator
178− noEmbedded
103+ (Maybe MaxProperties)
179− (run (fmap maybeToList . AR.uniqueItems . _unUniqueItems))
104+ MaxPropertiesInvalid
105+maxPropertiesValidator = Validator noEmbedded (run maxPropertiesVal)
181−data ItemsContext schema =
107+minPropertiesValidator
182− ItemsContext
108+ :: Validator
183− (Maybe (AR.AdditionalItems schema))
109+ a
184− (AR.Items schema)
110+ (Maybe MinProperties)
185− deriving (Eq, Show)
111+ MinPropertiesInvalid
112+minPropertiesValidator = Validator noEmbedded (run minPropertiesVal)
187−instance FromJSON schema => FromJSON (ItemsContext schema) where
114+requiredValidator :: Validator a (Maybe Required) ()
188− parseJSON = withObject "ItemsContext" $ \o -> ItemsContext
115+requiredValidator = Validator noEmbedded (run requiredVal)
189− <$> o .:! "additionalItems"
192−items
117+dependenciesValidator
193− :: (schema -> Value -> [Fail err])
118+ :: (schema -> Value -> [err])
194− -> Validator schema (Maybe (ItemsContext schema)) (AR.ItemsInvalid err)
119+ -> Validator
121+ (Maybe (DependenciesValidator schema))
122+ (DependenciesInvalid err)
123+dependenciesValidator f =
196 Validator
124 Validator
197− (\a -> case a of
125+ (maybe mempty ( (\a -> (mempty, a))
198− Nothing -> mempty
126+ . catMaybes . fmap checkDependency
199− Just (ItemsContext _ b) ->
127+ . HM.elems . _unDependenciesValidator
201− AR.ItemsObject c -> (mempty, pure c)
129+ (run (dependenciesVal f))
202− AR.ItemsArray cs -> (mempty, cs))
130+ where
203− (run (\(ItemsContext a b) -> AR.items f a b))
131+ checkDependency :: Dependency schema -> Maybe schema
204−
132+ checkDependency (PropertyDependency _) = Nothing
205−newtype AdditionalItemsContext schema
133+ checkDependency (SchemaDependency s) = Just s
206− = AdditionalItemsContext
207− { _unAdditionalItemsContext :: AR.AdditionalItems schema }
210−instance FromJSON schema => FromJSON (AdditionalItemsContext schema) where
211− parseJSON = withObject "AdditionalItemsContext" $ \o ->
212− AdditionalItemsContext <$> o .: "additionalItems"
214−-- | Since 'items' will always take care of validating 'additionalItems'
135+propertiesRelatedValidator
215−-- as well, the actual validation side of 'additionalItemsEmbedded' is
136+ :: (schema -> Value -> [err])
217−additionalItemsEmbedded
218− :: Validator
137+ -> Validator
220− (Maybe (AdditionalItemsContext schema))
139+ (PropertiesRelated schema)
221− err
140+ (PropertiesRelatedInvalid err)
222−additionalItemsEmbedded=
141+propertiesRelatedValidator f =
223− Validator
142+ Validator
144+ , HM.elems (fromMaybe mempty (_propProperties a))
145+ <> HM.elems (fromMaybe mempty (_propPattern a))
224− (\a -> case a of
146+ <> case _propAdditional a of
225− Just (AdditionalItemsContext (AR.AdditionalObject b)) ->
147+ Just (AdditionalPropertiesObject b) -> [b]
227− _ -> (mempty, mempty))
148+ _ -> mempty
150+ (\a b -> case fromJSONEither b of
228− (const (const mempty))
151+ Left _ -> mempty
152+ Right c -> maybeToList (propertiesRelatedVal f a c))
230newtype Definitions schema
154newtype Definitions schema
231 = Definitions { _unDefinitions :: HashMap Text schema }
155 = Definitions { _unDefinitions :: HashMap Text schema }
@@ -235,11 +159,9 @@ instance FromJSON schema => FromJSON (Definitions schema) where
235 parseJSON = withObject "Definitions" $ \o ->
159 parseJSON = withObject "Definitions" $ \o ->
236 Definitions <$> o .: "definitions"
160 Definitions <$> o .: "definitions"
238−-- | Placing this here since it's similar to @"additionalItems"@.
239−-- in that its validator doesn't run.
241−-- TODO: Add tests to the language agnostic test suite for both
162+-- TODO: Add tests to the language agnostic test suite to
163+-- make sure these schemas are embedded correctly
242−-- @"additionalItems"@ and this.
164+-- (and do so for @"additionalItems"@ as well).
243definitionsEmbedded
165definitionsEmbedded
244 :: Validator
166 :: Validator
@@ -252,299 +174,69 @@ definitionsEmbedded =
252 Nothing -> (mempty, mempty))
174 Nothing -> (mempty, mempty))
253 (const (const mempty))
175 (const (const mempty))
255−--------------------------------------------------
257−--------------------------------------------------
259−newtype MaxProperties
260− = MaxProperties { _unMaxProperties :: Int }
263−instance FromJSON MaxProperties where
264− parseJSON = withObject "MaxProperties" $ \o ->
265− MaxProperties <$> o .: "maxProperties"
267−maxProperties :: Validator a (Maybe MaxProperties) ()
271− (run (fmap maybeToList . OB.maxProperties . _unMaxProperties))
273−newtype MinProperties
274− = MinProperties { _unMinProperties :: Int }
277−instance FromJSON MinProperties where
278− parseJSON = withObject "MinProperties" $ \o ->
279− MinProperties <$> o .: "minProperties"
281−minProperties :: Validator a (Maybe MinProperties) ()
285− (run (fmap maybeToList . OB.minProperties . _unMinProperties))
287−newtype RequiredContext
288− = RequiredContext { _unRequiredContext :: OB.Required }
291−instance FromJSON RequiredContext where
292− parseJSON = withObject "RequiredContext" $ \o ->
293− RequiredContext <$> o .: "required"
295−required :: Validator a (Maybe RequiredContext) ()
299− (run (fmap maybeToList . OB.required . _unRequiredContext))
301−newtype DependenciesContext schema
302− = DependenciesContext
303− { _unDependenciesContext :: HashMap Text (OB.Dependency schema) }
306−instance FromJSON schema => FromJSON (DependenciesContext schema) where
307− parseJSON = withObject "DependenciesContext" $ \o ->
308− DependenciesContext <$> o .: "dependencies"
311− :: (schema -> Value -> [Fail err])
314− (Maybe (DependenciesContext schema))
315− (OB.DependencyInvalid err)
318− (maybe mempty ( (\a -> (mempty, a))
319− . catMaybes . fmap checkDependency
320− . HM.elems . _unDependenciesContext
322− (run (OB.dependencies f . _unDependenciesContext))
324− checkDependency :: OB.Dependency schema -> Maybe schema
325− checkDependency (OB.PropertyDependency _) = Nothing
326− checkDependency (OB.SchemaDependency s) = Just s
328−data PropertiesContext schema
330− (Maybe (HashMap Text schema))
331− (Maybe (OB.AdditionalProperties schema))
332− (HashMap Text schema)
335−instance FromJSON schema => FromJSON (PropertiesContext schema) where
336− parseJSON = withObject "PropertiesContext" $ \o -> PropertiesContext
337− <$> o .:! "patternProperties"
338− <*> o .:! "additionalProperties"
339− <*> o .: "properties"
342− :: (schema -> Value -> [Fail err])
345− (Maybe (PropertiesContext schema))
346− (OB.PropertiesInvalid err)
350− Just (PropertiesContext _ _ b) -> (mempty, HM.elems b)
351− Nothing -> (mempty, mempty))
352− (run (\(PropertiesContext a b c) -> OB.properties f a b c))
354−-- | The first argument is whether the validator should be run.
355−-- If @"properties"@ exists it will be parsed to 'False'.
356−data PatternPropertiesContext schema
357− = PatternPropertiesContext
359− (Maybe (OB.AdditionalProperties schema))
360− (HashMap Text schema)
363−instance FromJSON schema => FromJSON (PatternPropertiesContext schema) where
364− parseJSON = withObject "PatternPropertiesContext" $ \o ->
365− PatternPropertiesContext
367− <*> o .:! "additionalProperties"
368− <*> o .: "patternProperties"
370− shouldRun :: HashMap Text Value -> Parser Bool
372− a <- o .:! "properties"
373− pure $ isNothing (a :: Maybe (HashMap Text schema))
376− :: (schema -> Value -> [Fail err])
379− (Maybe (PatternPropertiesContext schema))
380− (OB.PatternPropertiesInvalid err)
381−patternProperties f =
384− Just (PatternPropertiesContext _ _ b) -> (mempty, HM.elems b)
385− Nothing -> (mempty, mempty))
386− (run (\(PatternPropertiesContext a b c) -> OB.patternProperties f a b c))
388−-- | The first argument is whether the validator should be run.
389−-- If @"properties"@ or @"patternProperties"@ exist it will be parsed
391−data AdditionalPropertiesContext schema
392− = AdditionalPropertiesContext
394− (OB.AdditionalProperties schema)
397−instance FromJSON schema => FromJSON (AdditionalPropertiesContext schema) where
398− parseJSON = withObject "AdditionalPropertiesContext" $ \o ->
399− AdditionalPropertiesContext
401− <*> o .: "additionalProperties"
403− shouldRun :: HashMap Text Value -> Parser Bool
405− a <- o .:! "properties"
406− b <- o .:! "patternProperties"
407− pure $ isNothing (a :: Maybe (HashMap Text schema))
408− && isNothing (b :: Maybe (HashMap Text schema))
411− :: (schema -> Value -> [Fail err])
414− (Maybe (AdditionalPropertiesContext schema))
415− (OB.AdditionalPropertiesInvalid err)
416−additionalProperties f =
420− Just (AdditionalPropertiesContext _ b) ->
422− OB.AdditionalPropertiesBool _ -> (mempty, mempty)
423− OB.AdditionalPropertiesObject c -> (mempty, pure c))
424− (run (\(AdditionalPropertiesContext a b) -> OB.additionalProperties f a b))
426--------------------------------------------------
177--------------------------------------------------
428--------------------------------------------------
179--------------------------------------------------
430−newtype Ref
181+refValidator
431− = Ref { _unRef :: Text }
434−instance FromJSON Ref where
435− parseJSON = withObject "Ref" $ \o ->
439 :: (FromJSON schema, ToJSON schema)
182 :: (FromJSON schema, ToJSON schema)
440− => AN.VisitedSchemas
183+ => VisitedSchemas
441 -> Maybe Text
184 -> Maybe Text
442 -> (Maybe Text -> Maybe schema)
185 -> (Maybe Text -> Maybe schema)
443− -> (AN.VisitedSchemas -> Maybe Text -> schema -> Value -> [Fail err])
186+ -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])
444− -> Validator a (Maybe Ref) (AN.RefInvalid err)
187+ -> Validator a (Maybe Ref) (RefInvalid err)
445−ref visited scope getRef f =
188+refValidator visited scope getRef f =
446 Validator
189 Validator
447 noEmbedded
190 noEmbedded
448− (run (AN.ref visited scope getRef f . _unRef))
191+ (run (refVal visited scope getRef f))
450−newtype EnumContext
193+enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid
451− = EnumContext { _unEnumContext :: AN.EnumVal }
194+enumValidator = Validator noEmbedded (run enumVal)
454−instance FromJSON EnumContext where
196+typeValidator :: Validator a (Maybe TypeContext) TypeValidatorInvalid
455− parseJSON = withObject "EnumContext" $ \o ->
197+typeValidator = Validator noEmbedded (run typeVal)
456− EnumContext <$> o .: "enum"
458−enumVal :: Validator a (Maybe EnumContext) ()
199+allOfValidator
462− (run (fmap maybeToList . AN.enumVal . _unEnumContext))
465− = TypeContext { _unTypeContext :: AN.TypeVal }
468−instance FromJSON TypeContext where
469− parseJSON = withObject "TypeContext" $ \o ->
470− TypeContext <$> o .: "type"
472−typeVal :: Validator a (Maybe TypeContext) ()
476− (run (fmap maybeToList . AN.typeVal . _unTypeContext))
479− = AllOf { _unAllOf :: NonEmpty schema }
482−instance FromJSON schema => FromJSON (AllOf schema) where
483− parseJSON = withObject "AllOf" $ \o ->
484− AllOf <$> o .: "allOf"
487− :: (schema -> Value -> [Fail err])
200+ :: (schema -> Value -> [err])
488− -> Validator schema (Maybe (AllOf schema)) err
201+ -> Validator schema (Maybe (AllOf schema)) (AllOfInvalid err)
489−allOf f =
202+allOfValidator f =
490 Validator
203 Validator
491 (\a -> case a of
204 (\a -> case a of
492 Just (AllOf b) -> (NE.toList b, mempty)
205 Just (AllOf b) -> (NE.toList b, mempty)
493 Nothing -> (mempty, mempty))
206 Nothing -> (mempty, mempty))
494− (run (AN.allOf f . _unAllOf))
207+ (run (allOfVal f))
497− = AnyOf { _unAnyOf :: NonEmpty schema }
500−instance FromJSON schema => FromJSON (AnyOf schema) where
209+anyOfValidator
501− parseJSON = withObject "AnyOf" $ \o ->
502− AnyOf <$> o .: "anyOf"
505− :: (schema -> Value -> [Fail err])
210+ :: (schema -> Value -> [err])
506− -> Validator schema (Maybe (AnyOf schema)) err
211+ -> Validator schema (Maybe (AnyOf schema)) (AnyOfInvalid err)
507−anyOf f =
212+anyOfValidator f =
508 Validator
213 Validator
509 (\a -> case a of
214 (\a -> case a of
510 Just (AnyOf b) -> (NE.toList b, mempty)
215 Just (AnyOf b) -> (NE.toList b, mempty)
511 Nothing -> (mempty, mempty))
216 Nothing -> (mempty, mempty))
512− (run (AN.anyOf f . _unAnyOf))
217+ (run (anyOfVal f))
515− = OneOf { _unOneOf :: NonEmpty schema }
518−instance FromJSON schema => FromJSON (OneOf schema) where
219+oneOfValidator
519− parseJSON = withObject "OneOf" $ \o ->
520− OneOf <$> o .: "oneOf"
523 :: ToJSON schema
220 :: ToJSON schema
524− => (schema -> Value -> [Fail err])
221+ => (schema -> Value -> [err])
525− -> Validator schema (Maybe (OneOf schema)) (AN.OneOfInvalid err)
222+ -> Validator schema (Maybe (OneOf schema)) (OneOfInvalid err)
526−oneOf f =
223+oneOfValidator f =
527 Validator
224 Validator
528 (\a -> case a of
225 (\a -> case a of
529 Just (OneOf b) -> (NE.toList b, mempty)
226 Just (OneOf b) -> (NE.toList b, mempty)
530 Nothing -> (mempty, mempty))
227 Nothing -> (mempty, mempty))
531− (run (AN.oneOf f . _unOneOf))
228+ (run (oneOfVal f))
533−newtype NotVal schema
230+notValidator
534− = NotVal { _unNotVal :: schema }
537−instance FromJSON schema => FromJSON (NotVal schema) where
538− parseJSON = withObject "NotVal" $ \o ->
539− NotVal <$> o .: "not"
542 :: ToJSON schema
231 :: ToJSON schema
543− => (schema -> Value -> [Fail err])
232+ => (schema -> Value -> [err])
544− -> Validator schema (Maybe (NotVal schema)) ()
233+ -> Validator
545−notVal f =
234+ schema
235+ (Maybe (NotValidator schema))
546 Validator
238 Validator
547 (\a -> case a of
239 (\a -> case a of
548− Just (NotVal b) -> (pure b, mempty)
240+ Just (NotValidator b) -> (pure b, mempty)
549− Nothing -> (mempty, mempty))
241+ Nothing -> (mempty, mempty))
550− (run (fmap maybeToList . AN.notVal f . _unNotVal))
242+ (run (notVal f))