@@ -1,530 +0,0 @@
1−-- | This is generally meant to be an internal module.
2−-- It's only exposed in case you want to make your own
3−-- 'Spec'. If you just want to use JSON Schema Draft 4
4−-- use the preassembled 'Data.JsonSchema.draft4' instead.
5−--
6−-- This module exposes three types of functions. To describe
7−-- them we'll use the properties validators as an example.
8−--
9−-- 1. Functions which describe how subschemas (if any)
10−-- are embedded in this validator. This is how 'fetchRefs'
11−-- is able to find "$refs" and "ids".
12−--
13−-- 2. Functions that aren't followed by apostrophes have the
14−-- type 'ValidatorGen' and are meant to be used in a 'Spec'.
15−-- Examples are 'properties' and 'additionalProperties'.
16−--
17−-- 3. Functions that are followed by a single apostrophe, such
18−-- as 'additionalProperties'', aren't meant to be used standalone
19−-- in a 'Spec'. Instead they're used by other validators. For
20−-- instance, 'additionalProperties' disables itself if the key
21−-- "properties" is present to allow 'additionalProperties' to
22−-- handle its validation. Placing the actual meat of
23−-- 'additionalProperties' in 'additionalProperties'' allows for
24−-- code reuse between 'properties' and 'additionalProperties'.
25−--
26−-- 4. Functions that are followed by a double apostrophe, such
27−-- as 'patternProperties''', return an enhanced validator. It
28−-- not only reports errors, but also the parts of the target
29−-- data that it matches. These functions also aren't used in
30−-- a 'Spec' instance, but are necessary helpers for actual
31−-- validators in certain situations.
32−
33−module Data.JsonSchema.Validators where
34−
35−import Control.Applicative
36−import Control.Monad
37−import Data.Aeson
38−import Data.Fixed (mod')
39−import Data.Hashable
40−import Data.HashMap.Strict (HashMap)
41−import qualified Data.HashMap.Strict as H
42−import Data.JsonSchema.Core
43−import Data.JsonSchema.JsonReference
44−import Data.JsonSchema.Utils
45−import Data.Maybe
46−import Data.Monoid
47−import Data.Text (Text)
48−import qualified Data.Text as T
49−import Data.Traversable
50−import Data.Vector (Vector)
51−import qualified Data.Vector as V
52−import Text.RegexPR
53−
54−--------------------------------------------------
55−-- Embedded Schema Layouts
56−--------------------------------------------------
57−
58−noEm :: Text -> Value -> Vector RawSchema
59−noEm _ _ = V.empty
60−
61−objEmbed :: Text -> Value -> Vector RawSchema
62−objEmbed t (Object o) = V.singleton $ RawSchema t o
63−objEmbed _ _ = V.empty
64−
65−-- TODO: optimize
66−arrayEmbed :: Text -> Value -> Vector RawSchema
67−arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs
68−arrayEmbed _ _ = V.empty
69−
70−objOrArrayEmbed :: Text -> Value -> Vector RawSchema
71−objOrArrayEmbed t v@(Object _) = objEmbed t v
72−objOrArrayEmbed t v@(Array _) = arrayEmbed t v
73−objOrArrayEmbed _ _ = V.empty
74−
75−objMembersEmbed :: Text -> Value -> Vector RawSchema
76−objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o
77−objMembersEmbed _ _ = V.empty
78−
79−--------------------------------------------------
80−-- Number Validators
81−--------------------------------------------------
82−
83−multipleOf :: ValidatorGen
84−multipleOf _ _ _ (Number val) = do
85− greaterThanZero val
86− Just (\x ->
87− case x of
88− (Number y) -> if y `mod'` val /= 0
89− then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val
90− else mempty
91− _ -> mempty)
92−multipleOf _ _ _ _ = Nothing
93−
94−maximumVal :: ValidatorGen
95−maximumVal _ _ s (Number val) =
96− let f = case H.lookup "exclusiveMaximum" (_rsObject s) of
97− Just (Bool a) -> if a then (>=) else (>)
98− _ -> (>)
99− in Just (\x ->
100− case x of
101− (Number y) -> if y `f` val
102− then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val
103− else mempty
104− _ -> mempty)
105−maximumVal _ _ _ _ = Nothing
106−
107−minimumVal :: ValidatorGen
108−minimumVal _ _ s (Number val) =
109− let f = case H.lookup "exclusiveMinimum" (_rsObject s) of
110− Just (Bool a) -> if a then (<=) else (<)
111− _ -> (<)
112− in Just (\x ->
113− case x of
114− (Number y) -> if y `f` val
115− then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val
116− else mempty
117− _ -> mempty)
118−minimumVal _ _ _ _ = Nothing
119−
120−--------------------------------------------------
121−-- String Validators
122−--------------------------------------------------
123−
124−maxLength :: ValidatorGen
125−maxLength _ _ _ v = do
126− val <- fromJSONInt v
127− greaterThanZero val
128− Just (\x ->
129− case x of
130− (String y) -> if T.length y > val
131− then V.singleton $ y <> " is greater than maxLength " <> tshow val
132− else mempty
133− _ -> mempty)
134−
135−minLength :: ValidatorGen
136−minLength _ _ _ v = do
137− val <- fromJSONInt v
138− greaterThanZero val
139− Just (\x ->
140− case x of
141− (String y) -> if T.length y < val
142− then V.singleton $ y <> " is less than minLength " <> tshow val
143− else mempty
144− _ -> mempty)
145−
146−pattern :: ValidatorGen
147−pattern _ _ _ (String val) =
148− Just (\x ->
149− case x of
150− (String t) ->
151− case matchRegexPR (T.unpack val) (T.unpack t) of
152− Nothing -> V.singleton $ t <> " fails to validate against pattern " <> val
153− Just _ -> mempty
154− _ -> mempty)
155−pattern _ _ _ _ = Nothing
156−
157−--------------------------------------------------
158−-- Array Validators
159−--------------------------------------------------
160−
161−-- | Also covers additionalItems.
162−--
163−-- We can leave additionalItems out of the spec HashMap, since items defaults to {},
164−-- and if it isn't present additionalItems will always validate successfully.
165−items :: ValidatorGen
166−items spec g s (Object val) =
167− let sub = compile spec g (RawSchema (_rsURI s) val)
168− in Just (\x ->
169− case x of
170− (Array ys) -> ys >>= validate sub
171− _ -> mempty)
172−items spec g s (Array vs) = do
173− os <- traverse toObj vs
174− let ss = compile spec g . RawSchema (_rsURI s) <$> os
175− let addItems = do
176− a <- H.lookup "additionalItems" (_rsObject s)
177− additionalItems' spec g s a
178− Just (\x ->
179− case x of
180− (Array ys) ->
181− let extras = V.drop (V.length os) ys
182− in join (V.zipWith validate ss ys) <> runMaybeVal addItems (Array extras)
183− _ -> mempty)
184−items _ _ _ _ = Nothing
185−
186−additionalItems' :: ValidatorGen
187−additionalItems' _ _ _ (Bool val) =
188− Just (\x ->
189− case x of
190− (Array ys) -> if not val && V.length ys > 0
191− then V.singleton ("Val error against additionalItems false for: " <> tshow x)
192− else mempty
193− _ -> mempty)
194−additionalItems' spec g s (Object val) =
195− let sub = compile spec g (RawSchema (_rsURI s) val)
196− in Just (\x ->
197− case x of
198− (Array ys) -> ys >>= validate sub
199− _ -> mempty)
200−additionalItems' _ _ _ _ = Nothing
201−
202−maxItems :: ValidatorGen
203−maxItems _ _ _ v = do
204− val <- fromJSONInt v
205− greaterThanZero val
206− Just (\x ->
207− case x of
208− (Array ys) -> if V.length ys > val
209− then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val
210− else mempty
211− _ -> mempty)
212−
213−minItems :: ValidatorGen
214−minItems _ _ _ v = do
215− val <- fromJSONInt v
216− greaterThanZero val
217− Just (\x ->
218− case x of
219− (Array ys) -> if V.length ys < val
220− then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val
221− else mempty
222− _ -> mempty)
223−
224−uniqueItems :: ValidatorGen
225−uniqueItems _ _ _ (Bool val) = do
226− unless val Nothing
227− Just (\x ->
228− case x of
229− (Array ys) -> if allUnique ys
230− then mempty
231− else V.singleton
232− ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)
233− _ -> mempty)
234−uniqueItems _ _ _ _ = Nothing
235−
236−--------------------------------------------------
237−-- Object Validators
238−--------------------------------------------------
239−
240−maxProperties :: ValidatorGen
241−maxProperties _ _ _ v = do
242− val <- fromJSONInt v
243− greaterThanZero val
244− Just (\x ->
245− case x of
246− (Object o) -> if H.size o > val
247− then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val
248− else mempty
249− _ -> mempty)
250−
251−minProperties :: ValidatorGen
252−minProperties _ _ _ v = do
253− val <- fromJSONInt v
254− greaterThanZero val
255− Just (\x ->
256− case x of
257− (Object o) -> if H.size o < val
258− then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val
259− else mempty
260− _ -> mempty)
261−
262−required :: ValidatorGen
263−required _ _ _ (Array vs) = do
264− when (V.length vs == 0) Nothing
265− ts <- traverse toTxt vs
266− let a = vectorToMap ts
267− when (H.size a /= V.length ts) Nothing
268− Just (\x ->
269− case x of
270− (Object o) -> if H.size (H.difference a o) > 0
271− then V.singleton $ "the keys of " <> tshow o
272− <> " don't contain all the required elements " <> tshow vs
273− else mempty
274− _ -> mempty)
275− where
276− -- TODO: optimize
277− vectorToMap :: (Eq a, Hashable a) => Vector a -> HashMap a Bool
278− vectorToMap vec = H.fromList $ zip (V.toList vec) (repeat True)
279−required _ _ _ _ = Nothing
280−
281−-- TODO: Fix up the properties* validators. They're all a huge mess, but at least
282−-- they work.
283−--
284−-- In order of what's tried: properties, patternProperties, additionalProperties
285−properties :: ValidatorGen
286−properties spec g s v = do
287− let mProps = properties'' spec g s v
288− let mPatProp = do
289− aV <- H.lookup "patternProperties" (_rsObject s)
290− patternProperties'' spec g s aV
291− let mAdd = do
292− aVal <- H.lookup "additionalProperties" (_rsObject s)
293− additionalProperties' spec g s aVal
294− when (isNothing mProps && isNothing mPatProp && isNothing mAdd) Nothing
295− Just (\x ->
296− case x of
297− (Object y) -> -- Got myself into a mess here.
298− let (e1s, remaining) = runMaybeVal' mProps (Object y)
299− (_, remaining') = runMaybeVal' mPatProp remaining
300− (e2s, _) = runMaybeVal' mPatProp (Object y)
301− in e1s <> e2s <> runMaybeVal mAdd remaining'
302− _ -> mempty)
303−
304−-- TODO: optimize
305−properties''
306− :: Spec
307− -> Graph
308− -> RawSchema
309− -> Value
310− -> Maybe (Value -> (Vector ValErr, Value))
311−properties'' spec g s (Object val) = do
312− os <- traverse toObj val
313− let oss = compile spec g . RawSchema (_rsURI s) <$> os
314− Just (\x ->
315− case x of
316− (Object y) -> ( join . V.fromList . H.elems $ H.intersectionWith validate oss y
317− , Object (H.difference y oss))
318− z -> (mempty, z))
319−properties'' _ _ _ _ = Nothing
320−
321−-- TODO: optimize
322−patternProperties''
323− :: Spec
324− -> Graph
325− -> RawSchema
326− -> Value
327− -> Maybe (Value -> (Vector ValErr, Value))
328−patternProperties'' spec g s (Object val) = do
329− os <- traverse toObj val
330− let vs = compile spec g . RawSchema (_rsURI s) <$> os
331− Just (\x ->
332− case x of
333− (Object y) -> let ms = matches (V.fromList . H.toList $ vs) <$> (V.fromList . H.toList $ y)
334− in (ms >>= runVals, leftovers ms)
335− _ -> (mempty, x))
336− where
337− matches :: Vector (Text, Schema) -> (Text, Value) -> (Text, Value, Vector Schema)
338− matches ss (k, v) = (k, v, ss >>= match k)
339−
340− match :: Text -> (Text, Schema) -> Vector Schema
341− match k (r, sc) =
342− case matchRegexPR (T.unpack r) (T.unpack k) of
343− Nothing -> mempty
344− Just _ -> V.singleton sc
345−
346− runVals :: (Text, Value, Vector Schema) -> Vector ValErr
347− runVals (_,v,ss) = join $ validate <$> ss <*> pure v
348−
349− leftovers :: Vector (Text, Value, Vector Schema) -> Value
350− leftovers possiblyMatched =
351− let unmatched = V.filter (\(_,_,ss) -> V.length ss == 0) possiblyMatched
352− in Object . H.fromList . V.toList $ (\(v,k,_) -> (v,k)) <$> unmatched
353−
354−patternProperties'' _ _ _ _ = Nothing
355−
356−patternProperties :: ValidatorGen
357−patternProperties spec g s v = do
358− when (H.member "properties" (_rsObject s)) Nothing
359− let mPatProp = patternProperties'' spec g s v
360− -- TODO: checking additionalProperties as well doesn't help with tests
361− let mAdd = do
362− aVal <- H.lookup "additionalProperties" (_rsObject s)
363− additionalProperties' spec g s aVal
364− when (isNothing mPatProp && isNothing mAdd) Nothing
365− Just (\x ->
366− case x of
367− (Object y) ->
368− let (e2s, remaining') = runMaybeVal' mPatProp (Object y)
369− in e2s <> runMaybeVal mAdd remaining'
370− _ -> mempty)
371−
372−additionalProperties' :: ValidatorGen
373−additionalProperties' _ _ _ (Bool val) =
374− Just (\x ->
375− case x of
376− (Object y) -> if not val && H.size y > 0
377− then V.singleton ("Val error against additionalProperties false for: " <> tshow x)
378− else mempty
379− _ -> mempty)
380−additionalProperties' spec g s (Object val) =
381− let sub = compile spec g (RawSchema (_rsURI s) val)
382− in Just (\x ->
383− case x of
384− (Object y) -> (V.fromList . H.elems $ y) >>= validate sub -- TODO: optimize
385− _ -> mempty)
386−additionalProperties' _ _ _ _ = Nothing
387−
388−additionalProperties :: ValidatorGen
389−additionalProperties spec g s v = do
390− when (H.member "properties" (_rsObject s)) Nothing
391− when (H.member "patternProperties" (_rsObject s)) Nothing
392− additionalProperties' spec g s v
393−
394−-- TODO: optimize
395−--
396−-- http://json-schema.org/latest/json-schema-validation.html#anchor70
397−--
398−-- This keyword's value MUST be an object.
399−-- Each value of this object MUST be either an object or an array.
400−--
401−-- If the value is an object, it MUST be a valid JSON Schema.
402−-- This is called a schema dependency.
403−--
404−-- If the value is an array, it MUST have at least one element.
405−-- Each element MUST be a string, and elements in the array MUST be unique.
406−-- This is called a property dependency.
407−dependencies :: ValidatorGen
408−dependencies spec g s (Object val) = do
409− let vs = V.fromList $ H.toList val
410− let schemaDeps = vs >>= toSchemaDep spec g
411− let propDeps = vs >>= toPropDep
412− when (V.length schemaDeps + V.length propDeps /= V.length vs) Nothing
413− Just (\x ->
414− case x of
415− (Object y) -> join $ (valSD <$> schemaDeps <*> pure y) <> (valPD <$> propDeps <*> pure y)
416− _ -> mempty)
417− where
418− toSchemaDep :: Spec -> Graph -> (Text, Value) -> Vector (Text, Schema)
419− toSchemaDep spc gr (t, Object o) = V.singleton (t, compile spc gr $ RawSchema (_rsURI s) o)
420− toSchemaDep _ _ _ = mempty
421−
422− toPropDep :: (Text, Value) -> Vector (Text, Vector Text)
423− toPropDep (t, Array a) =
424− if V.length a <= 0
425− then mempty
426− else case traverse toTxt a of
427− Nothing -> mempty
428− Just ts ->
429− if allUnique ts
430− then V.singleton (t, ts)
431− else mempty
432− toPropDep _ = mempty
433−
434− valSD :: (Text, Schema) -> HashMap Text Value -> Vector ValErr
435− valSD (t, sub) d =
436− case H.lookup t d of
437− Nothing -> mempty
438− Just _ -> validate sub (Object d)
439−
440− valPD :: (Text, Vector Text) -> HashMap Text Value -> Vector ValErr
441− valPD (t, ts) d =
442− case H.lookup t d of
443− Nothing -> mempty
444− Just _ ->
445− case traverse ($ d) (H.lookup <$> ts) of
446− Nothing -> V.singleton
447− ("Val error against property dependency with the key "
448− <> t <> " and the value " <> tshow ts <> " for: " <> tshow d)
449− Just _ -> mempty
450−
451−dependencies _ _ _ _ = Nothing
452−
453−--------------------------------------------------
454−-- Any Validators
455−--------------------------------------------------
456−
457−enum :: ValidatorGen
458−enum _ _ _ (Array vs) = do
459− unless (V.length vs > 0 && allUnique vs) Nothing
460− Just (\x ->
461− if V.elem x vs
462− then mempty
463− else V.singleton $ tshow x <> " is not an element of enum " <> tshow vs)
464−enum _ _ _ _ = Nothing
465−
466−typeVal :: ValidatorGen
467−typeVal _ _ _ (String val) = Just (\x -> isJsonType x (V.singleton val))
468−typeVal _ _ _ (Array vs) = do
469− ts <- traverse toTxt vs
470− unless (allUnique ts) Nothing
471− Just (`isJsonType` ts)
472−typeVal _ _ _ _ = Nothing
473−
474−allOf :: ValidatorGen
475−allOf spec g s (Array vs) = do
476− os <- traverse toObj vs
477− let ss = compile spec g . RawSchema (_rsURI s) <$> os
478− Just (\x -> join $ validate <$> ss <*> pure x)
479−allOf _ _ _ _ = Nothing
480−
481−anyOf :: ValidatorGen
482−anyOf spec g s (Array vs) = do
483− os <- traverse toObj vs
484− let ss = compile spec g . RawSchema (_rsURI s) <$> os
485− Just (\x ->
486− if V.elem V.empty (validate <$> ss <*> pure x)
487− then mempty
488− else V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x))
489−anyOf _ _ _ _ = Nothing
490−
491−oneOf :: ValidatorGen
492−oneOf spec g s (Array vs) = do
493− os <- traverse toObj vs
494− let ss = compile spec g . RawSchema (_rsURI s) <$> os
495− Just (\x ->
496− if count V.empty (validate <$> ss <*> pure x) == 1
497− then mempty
498− else V.singleton ("Val error against oneOf " <> tshow vs <> " for: " <> tshow x))
499−oneOf _ _ _ _ = Nothing
500−
501−notValidator :: ValidatorGen
502−notValidator spec g s (Object val) = do
503− let sub = compile spec g (RawSchema (_rsURI s) val)
504− Just (\x ->
505− if V.null $ validate sub x
506− then V.singleton ("Val error against not validator " <> tshow val <> " for: " <> tshow x)
507− else mempty)
508−notValidator _ _ _ _ = Nothing
509−
510−-- http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03
511−--
512−-- TODO: Any members other than "$ref" in a JSON Reference object SHALL be
513−-- ignored.
514−ref :: ValidatorGen
515−ref spec g s (String val) = do
516− (reference, pointer) <- refAndP (_rsURI s `combineIdAndRef` val)
517− r <- RawSchema reference <$> H.lookup reference g
518− sc <- pointerToSchema pointer r
519− Just $ validate (compile spec g sc)
520− where
521− pointerToSchema :: Text -> RawSchema -> Maybe RawSchema
522− pointerToSchema pntr rawS = do
523− mVal <- jsonPointer pntr (Object . _rsObject $ rawS)
524− case mVal of
525− (Object o) -> Just $ RawSchema (_rsURI rawS) o
526− _ -> Nothing
527−ref _ _ _ _ = Nothing
528−
529−noVal :: ValidatorGen
530−noVal _ _ _ _ = Just (const V.empty)