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