@@ -8,6 +8,7 @@ module Data.JsonSchema.Validators where
88import Control.Applicative
99import Control.Monad
1010import Data.Aeson
11+import Data.Either
1112import Data.Fixed (mod')
1213import Data.Hashable
1314import Data.HashMap.Strict (HashMap)
@@ -18,6 +19,7 @@ import Data.JsonSchema.Helpers
1819import Data.JsonSchema.Reference
1920import Data.Maybe
2021import Data.Monoid
22+import Data.Scientific
2123import Data.Text (Text)
2224import qualified Data.Text as T
2325import Data.Text.Encoding
@@ -38,37 +40,43 @@ multipleOf _ _ _ (Number val) = do
3840 case x of
3941 Number y ->
4042 if y `mod'` val /= 0
41− then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val
43+ then V.singleton (tshow y <> " isn't a multiple of " <> tshow val)
4244 else mempty
4345 _ -> mempty)
4446multipleOf _ _ _ _ = Nothing
4547
4648maximumVal :: ValidatorGen
4749maximumVal _ _ s (Number val) =
48− let f = case H.lookup "exclusiveMaximum" (_rsObject s) of
49− Just (Bool a) -> if a then (>=) else (>)
50− _ -> (>)
51− in Just (\x ->
50+ Just (\x ->
5251 case x of
5352 Number y ->
54− if y `f` val
55− then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val
53+ if y `greater` val
54+ then V.singleton (tshow y <> " fails to validate against maximum " <> tshow val)
5655 else mempty
5756 _ -> mempty)
57+ where
58+ greater :: Scientific -> Scientific -> Bool
59+ greater =
60+ case H.lookup "exclusiveMaximum" (_rsObject s) of
61+ Just (Bool a) -> if a then (>=) else (>)
62+ _ -> (>)
5863maximumVal _ _ _ _ = Nothing
5964
6065minimumVal :: ValidatorGen
6166minimumVal _ _ s (Number val) =
62− let f = case H.lookup "exclusiveMinimum" (_rsObject s) of
63− Just (Bool a) -> if a then (<=) else (<)
64− _ -> (<)
65− in Just (\x ->
67+ Just (\x ->
6668 case x of
6769 Number y ->
68− if y `f` val
69− then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val
70+ if y `lesser` val
71+ then V.singleton (tshow y <> " fails to validate against minimum " <> tshow val)
7072 else mempty
7173 _ -> mempty)
74+ where
75+ lesser :: Scientific -> Scientific -> Bool
76+ lesser =
77+ case H.lookup "exclusiveMinimum" (_rsObject s) of
78+ Just (Bool a) -> if a then (<=) else (<)
79+ _ -> (<)
7280minimumVal _ _ _ _ = Nothing
7381
7482--------------------------------------------------
@@ -83,7 +91,7 @@ maxLength _ _ _ v = do
8391 case x of
8492 String y ->
8593 if T.length y > val
86− then V.singleton $ y <> " is greater than maxLength " <> tshow val
94+ then V.singleton (y <> " is greater than maxLength " <> tshow val)
8795 else mempty
8896 _ -> mempty)
8997
@@ -95,7 +103,7 @@ minLength _ _ _ v = do
95103 case x of
96104 String y ->
97105 if T.length y < val
98− then V.singleton $ y <> " is less than minLength " <> tshow val
106+ then V.singleton (y <> " is less than minLength " <> tshow val)
99107 else mempty
100108 _ -> mempty)
101109
@@ -105,7 +113,7 @@ pattern _ _ _ (String val) =
105113 case x of
106114 String t ->
107115 case matchRegexPR (T.unpack val) (T.unpack t) of
108− Nothing -> V.singleton $ t <> " fails to validate against pattern " <> val
116+ Nothing -> V.singleton (t <> " fails to validate against pattern " <> val)
109117 Just _ -> mempty
110118 _ -> mempty)
111119pattern _ _ _ _ = Nothing
@@ -120,7 +128,7 @@ items spec g s (Object val) =
120128 let sub = compile spec g (RawSchema (_rsURI s) val)
121129 in Just (\x ->
122130 case x of
123− Array ys -> ys >>= validate sub
131+ Array ys -> ys >>= either id mempty . validate sub
124132 _ -> mempty)
125133items spec g s (Array vs) = do
126134 os <- traverse toObj vs
@@ -132,7 +140,8 @@ items spec g s (Array vs) = do
132140 case x of
133141 (Array ys) ->
134142 let extras = V.drop (V.length os) ys
135− in join (V.zipWith validate ss ys) <> runMaybeVal addItems (Array extras)
143+ in join (either id mempty <$> V.zipWith validate ss ys)
144+ <> runMaybeVal addItems (Array extras)
136145 _ -> mempty)
137146items _ _ _ _ = Nothing
138147
@@ -152,7 +161,7 @@ additionalItems spec g s (Object val) =
152161 let sub = compile spec g (RawSchema (_rsURI s) val)
153162 in Just (\x ->
154163 case x of
155− Array ys -> ys >>= validate sub
164+ Array ys -> ys >>= either id mempty . validate sub
156165 _ -> mempty)
157166additionalItems _ _ _ _ = Nothing
158167
@@ -164,7 +173,7 @@ maxItems _ _ _ v = do
164173 case x of
165174 Array ys ->
166175 if V.length ys > val
167− then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val
176+ then V.singleton (tshow ys <> " has more items than maxItems " <> tshow val)
168177 else mempty
169178 _ -> mempty)
170179
@@ -176,7 +185,7 @@ minItems _ _ _ v = do
176185 case x of
177186 Array ys ->
178187 if V.length ys < val
179− then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val
188+ then V.singleton (tshow ys <> " has fewer items than minItems " <> tshow val)
180189 else mempty
181190 _ -> mempty)
182191
@@ -203,7 +212,7 @@ maxProperties _ _ _ v = do
203212 case x of
204213 Object o ->
205214 if H.size o > val
206− then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val
215+ then V.singleton (tshow o <> " has more members than maxProperties " <> tshow val)
207216 else mempty
208217 _ -> mempty)
209218
@@ -215,7 +224,7 @@ minProperties _ _ _ v = do
215224 case x of
216225 Object o ->
217226 if H.size o < val
218− then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val
227+ then V.singleton (tshow o <> " has fewer members than minProperties " <> tshow val)
219228 else mempty
220229 _ -> mempty)
221230
@@ -229,8 +238,8 @@ required _ _ _ (Array vs) = do
229238 case x of
230239 Object o ->
231240 if H.size (H.difference a o) > 0
232− then V.singleton $ "the keys of " <> tshow o <>
233− " don't contain all the required elements " <> tshow vs
241+ then V.singleton ("the keys of: " <> tshow o <>
242+ " don't contain all the required elements: " <> tshow vs)
234243 else mempty
235244 _ -> mempty)
236245 where
@@ -244,7 +253,7 @@ required _ _ _ _ = Nothing
244253-- In order of what's tried: properties, patternProperties, additionalProperties
245254properties :: ValidatorGen
246255properties spec g s v = do
247− let mProps = propertiesMatches spec g s v
256+ let mProps = propertiesMatches v
248257 let mPatProp = do
249258 aV <- H.lookup "patternProperties" (_rsObject s)
250259 patternPropertiesMatches spec g s aV
@@ -260,6 +269,17 @@ properties spec g s v = do
260269 (e2s, _) = runMaybeVal' mPatProp (Object y)
261270 in e1s <> e2s <> runMaybeVal mAdd remaining'
262271 _ -> mempty)
272+ where
273+ propertiesMatches :: Value -> Maybe (Value -> (Vector ValErr, Value))
274+ propertiesMatches (Object val) = do
275+ os <- traverse toObj val
276+ let oss = compile spec g . RawSchema (_rsURI s) <$> os
277+ Just (\x ->
278+ case x of
279+ Object y -> ( join . vectorOfElems $ either id mempty <$> H.intersectionWith validate oss y
280+ , Object $ H.difference y oss)
281+ z -> (mempty, z))
282+ propertiesMatches _ = Nothing
263283
264284patternProperties :: ValidatorGen
265285patternProperties spec g s v = do
@@ -292,7 +312,7 @@ runAdditionalProperties spec g s (Object val) =
292312 let sub = compile spec g (RawSchema (_rsURI s) val)
293313 in Just (\x ->
294314 case x of
295− Object y -> vectorOfElems y >>= validate sub
315+ Object y -> vectorOfElems y >>= either id mempty . validate sub
296316 _ -> mempty)
297317runAdditionalProperties _ _ _ _ = Nothing
298318
@@ -304,25 +324,24 @@ additionalProperties spec g s v = do
304324
305325-- http://json-schema.org/latest/json-schema-validation.html#anchor70
306326--
307−-- This keyword's value MUST be an object.
308−-- Each value of this object MUST be either an object or an array.
309−--
310−-- If the value is an object, it MUST be a valid JSON Schema.
311−-- This is called a schema dependency.
312−--
313−-- If the value is an array, it MUST have at least one element.
314−-- Each element MUST be a string, and elements in the array MUST be unique.
315−-- This is called a property dependency.
327+-- > This keyword's value MUST be an object.
328+-- > Each value of this object MUST be either an object or an array.
329+-- >
330+-- > If the value is an object, it MUST be a valid JSON Schema.
331+-- > This is called a schema dependency.
332+-- >
333+-- > If the value is an array, it MUST have at least one element.
334+-- > Each element MUST be a string, and elements in the array MUST be unique.
335+-- > This is called a property dependency.
316336dependencies :: ValidatorGen
317337dependencies spec g s (Object val) = do
318338 let vs = hmToVector val
319− let schemaDeps = vs >>= toSchemaDep spec g
320− let propDeps = vs >>= toPropDep
339+ schemaDeps = vs >>= toSchemaDep spec g
340+ propDeps = vs >>= toPropDep
321341 when (V.length schemaDeps + V.length propDeps /= V.length vs) Nothing
322342 Just (\x ->
323343 case x of
324− Object y -> join $ (valSD <$> schemaDeps <*> pure y)
325− <> (valPD <$> propDeps <*> pure y)
344+ Object y -> join $ (valSD <$> schemaDeps <*> pure y) <> (valPD <$> propDeps <*> pure y)
326345 _ -> mempty)
327346 where
328347 toSchemaDep :: Spec -> Graph -> (Text, Value) -> Vector (Text, Schema)
@@ -346,7 +365,7 @@ dependencies spec g s (Object val) = do
346365 valSD (t, sub) d =
347366 case H.lookup t d of
348367 Nothing -> mempty
349− Just _ -> validate sub (Object d)
368+ Just _ -> either id (const mempty) $ validate sub (Object d)
350369
351370 valPD :: (Text, Vector Text) -> HashMap Text Value -> Vector ValErr
352371 valPD (t, ts) d =
@@ -354,9 +373,8 @@ dependencies spec g s (Object val) = do
354373 Nothing -> mempty
355374 Just _ ->
356375 case traverse ($ d) (H.lookup <$> ts) of
357− Nothing -> V.singleton
358− ("Val error against property dependency with the key "
359− <> t <> " and the value " <> tshow ts <> " for: " <> tshow d)
376+ Nothing -> V.singleton ("Val error against property dependency with key: " <> t
377+ <> " and value " <> tshow ts <> " for: " <> tshow d)
360378 Just _ -> mempty
361379
362380dependencies _ _ _ _ = Nothing
@@ -365,13 +383,23 @@ dependencies _ _ _ _ = Nothing
365383-- * Any Validators
366384--------------------------------------------------
367385
386+-- | http://json-schema.org/latest/json-schema-validation.html#anchor76
387+--
388+-- > The value of this keyword MUST be an array.
389+-- > This array MUST have at least one element.
390+-- > Elements in the array MUST be unique.
391+-- >
392+-- > Elements in the array MAY be of any type, including null.
393+--
394+-- NOTE: We actually respect this, and don't build the validator
395+-- if any of the elements aren't unique.
368396enum :: ValidatorGen
369397enum _ _ _ (Array vs) = do
370− unless (V.length vs > 0 && allUnique vs) Nothing
398+ when (V.null vs || not (allUnique vs)) Nothing
371399 Just (\x ->
372400 if V.elem x vs
373401 then mempty
374− else V.singleton $ tshow x <> " is not an element of enum " <> tshow vs)
402+ else V.singleton (tshow x <> " is not an element of enum " <> tshow vs))
375403enum _ _ _ _ = Nothing
376404
377405typeVal :: ValidatorGen
@@ -386,7 +414,7 @@ allOf :: ValidatorGen
386414allOf spec g s (Array vs) = do
387415 os <- traverse toObj vs
388416 let ss = compile spec g . RawSchema (_rsURI s) <$> os
389− Just (\x -> join $ validate <$> ss <*> pure x)
417+ Just (\x -> join . vLefts $ validate <$> ss <*> pure x)
390418allOf _ _ _ _ = Nothing
391419
392420anyOf :: ValidatorGen
@@ -394,9 +422,9 @@ anyOf spec g s (Array vs) = do
394422 os <- traverse toObj vs
395423 let ss = compile spec g . RawSchema (_rsURI s) <$> os
396424 Just (\x ->
397− if V.elem V.empty (validate <$> ss <*> pure x)
398− then mempty
399− else V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x))
425+ case listToMaybe . rights $ validate <$> V.toList ss <*> pure x of
426+ Nothing -> V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x)
427+ Just _ -> mempty )
400428anyOf _ _ _ _ = Nothing
401429
402430oneOf :: ValidatorGen
@@ -404,7 +432,7 @@ oneOf spec g s (Array vs) = do
404432 os <- traverse toObj vs
405433 let ss = compile spec g . RawSchema (_rsURI s) <$> os
406434 Just (\x ->
407− if count V.empty (validate <$> ss <*> pure x) == 1
435+ if V.length (vRights $ validate <$> ss <*> pure x) == 1
408436 then mempty
409437 else V.singleton ("Val error against oneOf " <> tshow vs <> " for: " <> tshow x))
410438oneOf _ _ _ _ = Nothing
@@ -413,9 +441,10 @@ notValidator :: ValidatorGen
413441notValidator spec g s (Object val) = do
414442 let sub = compile spec g (RawSchema (_rsURI s) val)
415443 Just (\x ->
416− if V.null $ validate sub x
417− then V.singleton ("Val error against not validator " <> tshow val <> " for: " <> tshow x)
418− else mempty)
444+ case validate sub x of
445+ Left _ -> mempty
446+ Right _ -> V.singleton ("Val error against not validator " <> tshow val
447+ <> " for: " <> tshow x))
419448notValidator _ _ _ _ = Nothing
420449
421450-- http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03
@@ -430,9 +459,10 @@ ref spec g s (String val) = do
430459 p <- eitherToMaybe $ jsonPointer urlDecoded
431460 case resolvePointer p (Object $ _rsObject r) of
432461 Right (Object o) ->
433− Just $ validate $ compile spec g $ RawSchema (_rsURI r) o
462+ let compiled = compile spec g $ RawSchema (_rsURI r) o
463+ in Just $ either id (const mempty) . validate compiled
434464 _ -> Nothing
435465ref _ _ _ _ = Nothing
436466
437467noVal :: ValidatorGen
438−noVal _ _ _ _ = Just (const V.empty)
468+noVal _ _ _ _ = Just (const mempty)