@@ -1,84 +1,33 @@
11-- | This is generally meant to be an internal module.
22-- 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.
3+-- 'Data.JsonSchema.Core.Spec'. If you just want to use
4+-- JSON Schema Draft 4 use the preassembled
5+-- 'Data.JsonSchema.draft4' instead.
326
337module Data.JsonSchema.Validators where
348
359import Control.Applicative
3610import Control.Monad
3711import Data.Aeson
38−import Data.Fixed (mod')
12+import Data.Fixed (mod')
3913import Data.Hashable
40−import Data.HashMap.Strict (HashMap)
41−import qualified Data.HashMap.Strict as H
14+import Data.HashMap.Strict (HashMap)
15+import qualified Data.HashMap.Strict as H
4216import Data.JsonPointer
4317import Data.JsonSchema.Core
18+import Data.JsonSchema.Helpers
4419import Data.JsonSchema.Reference
45−import Data.JsonSchema.Utils
4620import Data.Maybe
4721import Data.Monoid
48−import Data.Text (Text)
49−import qualified Data.Text as T
22+import Data.Text (Text)
23+import qualified Data.Text as T
5024import Data.Text.Encoding
5125import Data.Traversable
52−import Data.Vector (Vector)
53−import qualified Data.Vector as V
26+import Data.Vector (Vector)
27+import qualified Data.Vector as V
5428import Network.HTTP.Types.URI
5529import Text.RegexPR
5630
57−--------------------------------------------------
58−-- Embedded Schema Layouts
59−--------------------------------------------------
60−
61−noEm :: Text -> Value -> Vector RawSchema
62−noEm _ _ = V.empty
63−
64−objEmbed :: Text -> Value -> Vector RawSchema
65−objEmbed t (Object o) = V.singleton $ RawSchema t o
66−objEmbed _ _ = V.empty
67−
68−-- TODO: optimize
69−arrayEmbed :: Text -> Value -> Vector RawSchema
70−arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs
71−arrayEmbed _ _ = V.empty
72−
73−objOrArrayEmbed :: Text -> Value -> Vector RawSchema
74−objOrArrayEmbed t v@(Object _) = objEmbed t v
75−objOrArrayEmbed t v@(Array _) = arrayEmbed t v
76−objOrArrayEmbed _ _ = V.empty
77−
78−objMembersEmbed :: Text -> Value -> Vector RawSchema
79−objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o
80−objMembersEmbed _ _ = V.empty
81−
8231--------------------------------------------------
8332-- Number Validators
8433--------------------------------------------------
@@ -88,9 +37,10 @@ multipleOf _ _ _ (Number val) = do
8837 greaterThanZero val
8938 Just (\x ->
9039 case x of
91− (Number y) -> if y `mod'` val /= 0
92− then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val
93− else mempty
40+ Number y ->
41+ if y `mod'` val /= 0
42+ then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val
43+ else mempty
9444 _ -> mempty)
9545multipleOf _ _ _ _ = Nothing
9646
@@ -101,9 +51,10 @@ maximumVal _ _ s (Number val) =
10151 _ -> (>)
10252 in Just (\x ->
10353 case x of
104− (Number y) -> if y `f` val
105− then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val
106− else mempty
54+ Number y ->
55+ if y `f` val
56+ then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val
57+ else mempty
10758 _ -> mempty)
10859maximumVal _ _ _ _ = Nothing
10960
@@ -114,9 +65,10 @@ minimumVal _ _ s (Number val) =
11465 _ -> (<)
11566 in Just (\x ->
11667 case x of
117− (Number y) -> if y `f` val
118− then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val
119− else mempty
68+ Number y ->
69+ if y `f` val
70+ then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val
71+ else mempty
12072 _ -> mempty)
12173minimumVal _ _ _ _ = Nothing
12274
@@ -130,9 +82,10 @@ maxLength _ _ _ v = do
13082 greaterThanZero val
13183 Just (\x ->
13284 case x of
133− (String y) -> if T.length y > val
134− then V.singleton $ y <> " is greater than maxLength " <> tshow val
135− else mempty
85+ String y ->
86+ if T.length y > val
87+ then V.singleton $ y <> " is greater than maxLength " <> tshow val
88+ else mempty
13689 _ -> mempty)
13790
13891minLength :: ValidatorGen
@@ -141,16 +94,17 @@ minLength _ _ _ v = do
14194 greaterThanZero val
14295 Just (\x ->
14396 case x of
144− (String y) -> if T.length y < val
145− then V.singleton $ y <> " is less than minLength " <> tshow val
146− else mempty
97+ String y ->
98+ if T.length y < val
99+ then V.singleton $ y <> " is less than minLength " <> tshow val
100+ else mempty
147101 _ -> mempty)
148102
149103pattern :: ValidatorGen
150104pattern _ _ _ (String val) =
151105 Just (\x ->
152106 case x of
153− (String t) ->
107+ String t ->
154108 case matchRegexPR (T.unpack val) (T.unpack t) of
155109 Nothing -> V.singleton $ t <> " fails to validate against pattern " <> val
156110 Just _ -> mempty
@@ -162,22 +116,19 @@ pattern _ _ _ _ = Nothing
162116--------------------------------------------------
163117
164118-- | Also covers additionalItems.
165−--
166−-- We can leave additionalItems out of the spec HashMap, since items defaults to {},
167−-- and if it isn't present additionalItems will always validate successfully.
168119items :: ValidatorGen
169120items spec g s (Object val) =
170121 let sub = compile spec g (RawSchema (_rsURI s) val)
171122 in Just (\x ->
172123 case x of
173− (Array ys) -> ys >>= validate sub
174− _ -> mempty)
124+ Array ys -> ys >>= validate sub
125+ _ -> mempty)
175126items spec g s (Array vs) = do
176127 os <- traverse toObj vs
177128 let ss = compile spec g . RawSchema (_rsURI s) <$> os
178129 let addItems = do
179130 a <- H.lookup "additionalItems" (_rsObject s)
180− additionalItems' spec g s a
131+ additionalItems spec g s a
181132 Just (\x ->
182133 case x of
183134 (Array ys) ->
@@ -186,21 +137,25 @@ items spec g s (Array vs) = do
186137 _ -> mempty)
187138items _ _ _ _ = Nothing
188139
189−additionalItems' :: ValidatorGen
190−additionalItems' _ _ _ (Bool val) =
140+-- | Not included directly in the 'draft4' spec hashmap because it always
141+-- validates data unless 'items' is also present. This is because 'items'
142+-- defaults to {}.
143+additionalItems :: ValidatorGen
144+additionalItems _ _ _ (Bool val) =
191145 Just (\x ->
192146 case x of
193− (Array ys) -> if not val && V.length ys > 0
194− then V.singleton ("Val error against additionalItems false for: " <> tshow x)
195− else mempty
147+ Array ys ->
148+ if not val && V.length ys > 0
149+ then V.singleton ("Val error against additionalItems false for: " <> tshow x)
150+ else mempty
196151 _ -> mempty)
197−additionalItems' spec g s (Object val) =
152+additionalItems spec g s (Object val) =
198153 let sub = compile spec g (RawSchema (_rsURI s) val)
199154 in Just (\x ->
200155 case x of
201− (Array ys) -> ys >>= validate sub
202− _ -> mempty)
203−additionalItems' _ _ _ _ = Nothing
156+ Array ys -> ys >>= validate sub
157+ _ -> mempty)
158+additionalItems _ _ _ _ = Nothing
204159
205160maxItems :: ValidatorGen
206161maxItems _ _ _ v = do
@@ -208,9 +163,10 @@ maxItems _ _ _ v = do
208163 greaterThanZero val
209164 Just (\x ->
210165 case x of
211− (Array ys) -> if V.length ys > val
212− then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val
213− else mempty
166+ Array ys ->
167+ if V.length ys > val
168+ then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val
169+ else mempty
214170 _ -> mempty)
215171
216172minItems :: ValidatorGen
@@ -219,9 +175,10 @@ minItems _ _ _ v = do
219175 greaterThanZero val
220176 Just (\x ->
221177 case x of
222− (Array ys) -> if V.length ys < val
223− then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val
224− else mempty
178+ Array ys ->
179+ if V.length ys < val
180+ then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val
181+ else mempty
225182 _ -> mempty)
226183
227184uniqueItems :: ValidatorGen
@@ -231,8 +188,7 @@ uniqueItems _ _ _ (Bool val) = do
231188 case x of
232189 (Array ys) -> if allUnique ys
233190 then mempty
234− else V.singleton
235− ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)
191+ else V.singleton ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)
236192 _ -> mempty)
237193uniqueItems _ _ _ _ = Nothing
238194
@@ -246,9 +202,10 @@ maxProperties _ _ _ v = do
246202 greaterThanZero val
247203 Just (\x ->
248204 case x of
249− (Object o) -> if H.size o > val
250− then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val
251− else mempty
205+ Object o ->
206+ if H.size o > val
207+ then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val
208+ else mempty
252209 _ -> mempty)
253210
254211minProperties :: ValidatorGen
@@ -257,145 +214,95 @@ minProperties _ _ _ v = do
257214 greaterThanZero val
258215 Just (\x ->
259216 case x of
260− (Object o) -> if H.size o < val
261− then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val
262− else mempty
217+ Object o ->
218+ if H.size o < val
219+ then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val
220+ else mempty
263221 _ -> mempty)
264222
265223required :: ValidatorGen
266224required _ _ _ (Array vs) = do
267225 when (V.length vs == 0) Nothing
268226 ts <- traverse toTxt vs
269− let a = vectorToMap ts
227+ let a = vectorToMapSet ts
270228 when (H.size a /= V.length ts) Nothing
271229 Just (\x ->
272230 case x of
273− (Object o) -> if H.size (H.difference a o) > 0
274− then V.singleton $ "the keys of " <> tshow o
275− <> " don't contain all the required elements " <> tshow vs
276− else mempty
231+ Object o ->
232+ if H.size (H.difference a o) > 0
233+ then V.singleton $ "the keys of " <> tshow o <>
234+ " don't contain all the required elements " <> tshow vs
235+ else mempty
277236 _ -> mempty)
278237 where
279− -- TODO: optimize
280− vectorToMap :: (Eq a, Hashable a) => Vector a -> HashMap a Bool
281− vectorToMap vec = H.fromList $ zip (V.toList vec) (repeat True)
238+ vectorToMapSet :: (Eq a, Hashable a) => Vector a -> HashMap a Bool
239+ vectorToMapSet vec = vectorToHm $ (\x -> (x, True)) <$> vec
282240required _ _ _ _ = Nothing
283241
284−-- TODO: Fix up the properties* validators. They're all a huge mess, but at least
242+-- TODO: Fix up the properties validators. They're all a huge mess, but at least
285243-- they work.
286244--
287245-- In order of what's tried: properties, patternProperties, additionalProperties
288246properties :: ValidatorGen
289247properties spec g s v = do
290− let mProps = properties'' spec g s v
248+ let mProps = propertiesMatches spec g s v
291249 let mPatProp = do
292250 aV <- H.lookup "patternProperties" (_rsObject s)
293− patternProperties'' spec g s aV
251+ patternPropertiesMatches spec g s aV
294252 let mAdd = do
295253 aVal <- H.lookup "additionalProperties" (_rsObject s)
296− additionalProperties' spec g s aVal
254+ runAdditionalProperties spec g s aVal
297255 when (isNothing mProps && isNothing mPatProp && isNothing mAdd) Nothing
298256 Just (\x ->
299257 case x of
300− (Object y) -> -- Got myself into a mess here.
258+ Object y -> -- Got myself into a mess here.
301259 let (e1s, remaining) = runMaybeVal' mProps (Object y)
302260 (_, remaining') = runMaybeVal' mPatProp remaining
303261 (e2s, _) = runMaybeVal' mPatProp (Object y)
304262 in e1s <> e2s <> runMaybeVal mAdd remaining'
305263 _ -> mempty)
306264
307−-- TODO: optimize
308−properties''
309− :: Spec
310− -> Graph
311− -> RawSchema
312− -> Value
313− -> Maybe (Value -> (Vector ValErr, Value))
314−properties'' spec g s (Object val) = do
315− os <- traverse toObj val
316− let oss = compile spec g . RawSchema (_rsURI s) <$> os
317− Just (\x ->
318− case x of
319− (Object y) -> ( join . V.fromList . H.elems $ H.intersectionWith validate oss y
320− , Object (H.difference y oss))
321− z -> (mempty, z))
322−properties'' _ _ _ _ = Nothing
323−
324−-- TODO: optimize
325−patternProperties''
326− :: Spec
327− -> Graph
328− -> RawSchema
329− -> Value
330− -> Maybe (Value -> (Vector ValErr, Value))
331−patternProperties'' spec g s (Object val) = do
332− os <- traverse toObj val
333− let vs = compile spec g . RawSchema (_rsURI s) <$> os
334− Just (\x ->
335− case x of
336− (Object y) -> let ms = matches (V.fromList . H.toList $ vs) <$> (V.fromList . H.toList $ y)
337− in (ms >>= runVals, leftovers ms)
338− _ -> (mempty, x))
339− where
340− matches :: Vector (Text, Schema) -> (Text, Value) -> (Text, Value, Vector Schema)
341− matches ss (k, v) = (k, v, ss >>= match k)
342−
343− match :: Text -> (Text, Schema) -> Vector Schema
344− match k (r, sc) =
345− case matchRegexPR (T.unpack r) (T.unpack k) of
346− Nothing -> mempty
347− Just _ -> V.singleton sc
348−
349− runVals :: (Text, Value, Vector Schema) -> Vector ValErr
350− runVals (_,v,ss) = join $ validate <$> ss <*> pure v
351−
352− leftovers :: Vector (Text, Value, Vector Schema) -> Value
353− leftovers possiblyMatched =
354− let unmatched = V.filter (\(_,_,ss) -> V.length ss == 0) possiblyMatched
355− in Object . H.fromList . V.toList $ (\(v,k,_) -> (v,k)) <$> unmatched
356−
357−patternProperties'' _ _ _ _ = Nothing
358−
359265patternProperties :: ValidatorGen
360266patternProperties spec g s v = do
361267 when (H.member "properties" (_rsObject s)) Nothing
362− let mPatProp = patternProperties'' spec g s v
268+ let mPatProp = patternPropertiesMatches spec g s v
363269 -- TODO: checking additionalProperties as well doesn't help with tests
364270 let mAdd = do
365271 aVal <- H.lookup "additionalProperties" (_rsObject s)
366− additionalProperties' spec g s aVal
272+ runAdditionalProperties spec g s aVal
367273 when (isNothing mPatProp && isNothing mAdd) Nothing
368274 Just (\x ->
369275 case x of
370− (Object y) ->
276+ Object y ->
371277 let (e2s, remaining') = runMaybeVal' mPatProp (Object y)
372278 in e2s <> runMaybeVal mAdd remaining'
373279 _ -> mempty)
374280
375−additionalProperties' :: ValidatorGen
376−additionalProperties' _ _ _ (Bool val) =
281+-- | An implementation of the "additionalProperties" keyword that never
282+-- disables itself. Not included directly in the 'draft4' spec hashmap.
283+runAdditionalProperties :: ValidatorGen
284+runAdditionalProperties _ _ _ (Bool val) =
377285 Just (\x ->
378286 case x of
379− (Object y) -> if not val && H.size y > 0
380− then V.singleton ("Val error against additionalProperties false for: " <> tshow x)
381− else mempty
287+ Object y ->
288+ if not val && H.size y > 0
289+ then V.singleton ("Val error against additionalProperties false for: " <> tshow x)
290+ else mempty
382291 _ -> mempty)
383−additionalProperties' spec g s (Object val) =
292+runAdditionalProperties spec g s (Object val) =
384293 let sub = compile spec g (RawSchema (_rsURI s) val)
385294 in Just (\x ->
386295 case x of
387− (Object y) -> (V.fromList . H.elems $ y) >>= validate sub -- TODO: optimize
388− _ -> mempty)
389−additionalProperties' _ _ _ _ = Nothing
296+ Object y -> vectorOfElems y >>= validate sub
297+ _ -> mempty)
298+runAdditionalProperties _ _ _ _ = Nothing
390299
391300additionalProperties :: ValidatorGen
392301additionalProperties spec g s v = do
393302 when (H.member "properties" (_rsObject s)) Nothing
394303 when (H.member "patternProperties" (_rsObject s)) Nothing
395− additionalProperties' spec g s v
304+ runAdditionalProperties spec g s v
396305
397−-- TODO: optimize
398−--
399306-- http://json-schema.org/latest/json-schema-validation.html#anchor70
400307--
401308-- This keyword's value MUST be an object.
@@ -409,17 +316,19 @@ additionalProperties spec g s v = do
409316-- This is called a property dependency.
410317dependencies :: ValidatorGen
411318dependencies spec g s (Object val) = do
412− let vs = V.fromList $ H.toList val
319+ let vs = hmToVector val
413320 let schemaDeps = vs >>= toSchemaDep spec g
414321 let propDeps = vs >>= toPropDep
415322 when (V.length schemaDeps + V.length propDeps /= V.length vs) Nothing
416323 Just (\x ->
417324 case x of
418− (Object y) -> join $ (valSD <$> schemaDeps <*> pure y) <> (valPD <$> propDeps <*> pure y)
419− _ -> mempty)
325+ Object y -> join $ (valSD <$> schemaDeps <*> pure y)
326+ <> (valPD <$> propDeps <*> pure y)
327+ _ -> mempty)
420328 where
421329 toSchemaDep :: Spec -> Graph -> (Text, Value) -> Vector (Text, Schema)
422− toSchemaDep spc gr (t, Object o) = V.singleton (t, compile spc gr $ RawSchema (_rsURI s) o)
330+ toSchemaDep spc gr (t, Object o) =
331+ V.singleton (t, compile spc gr $ RawSchema (_rsURI s) o)
423332 toSchemaDep _ _ _ = mempty
424333
425334 toPropDep :: (Text, Value) -> Vector (Text, Vector Text)