git.iko.soy/typeable/hjsonschema
on master help sign in
Squash of intitial dev. All official tests pass.
14fbe45Ian Grant Jeffries
.gitmodulesnew file+3
compare with master
unifiedsplit
@@ -0,0 +1,3 @@
1+[submodule "JSON-Schema-Test-Suite"]
2+ path = JSON-Schema-Test-Suite
3+ url = https://github.com/json-schema/JSON-Schema-Test-Suite
JSON-Schema-Test-Suitenew file+1

Submodule changed.

MIT-LICENSE.txtnew file+20
@@ -0,0 +1,20 @@
1+The MIT License (MIT)
2+Copyright (c) 2015 Ian Grant Jeffries
3+
4+Permission is hereby granted, free of charge, to any person obtaining a copy
5+of this software and associated documentation files (the "Software"), to deal
6+in the Software without restriction, including without limitation the rights
7+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
8+copies of the Software, and to permit persons to whom the Software is
9+furnished to do so, subject to the following conditions:
10+
11+The above copyright notice and this permission notice shall be included in all
12+copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
18+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
19+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
20+OR OTHER DEALINGS IN THE SOFTWARE.
README.mdnew file+32
@@ -0,0 +1,32 @@
1+# Intro
2+
3+An implementation of [JSON Schema](http://json-schema.org/) v4 in haskell.
4+
5+# Status
6+
7+Still in development. Lacks documentation, example code, and real error messages.
8+
9+Also while all the official tests pass, its implementation of the `$ref` and `id` keywords is incomplete.
10+
11+# Install Tests
12+
13+ git submodule update --init
14+
15+# Run Tests
16+
17+ cd JSON-Schema-Test-Suite/remotes
18+ python -m SimpleHTTPServer 1234
19+
20+Then run the normal `cabal test` from another terminal.
21+
22+Note that the tests require an internet connection.
23+
24+# Notes
25+
26+This uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library fo the "pattern" validator. I have no idea if this is compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.
27+
28+# Credits
29+
30+Thanks to [Julian Berman](https://github.com/Julian) for the fantastic test suite.
31+
32+Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema is based on Aeson-Schema, and some code is directly from there.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
hjsonschema.cabalnew file+58
@@ -0,0 +1,58 @@
1+name: hjsonschema
2+version: 0.1.0.0
3+synopsis: Haskell implementation of JSON Schema v4.
4+homepage: https://github.com/seagreen/hjsonschema
5+license: MIT
6+license-file: MIT-LICENSE.txt
7+author: Ian Grant Jeffries
8+maintainer: ian@housejeffries.com
9+category: Data
10+build-type: Simple
11+extra-source-files: README.md
12+cabal-version: >=1.10
13+
14+library
15+ hs-source-dirs: src
16+ exposed-modules: Data.JsonSchema
17+ , Data.JsonSchema.JsonReference
18+ , Data.JsonSchema.Utils
19+ , Data.JsonSchema.Validators
20+ other-modules: Data.JsonSchema.Core
21+ default-language: Haskell2010
22+ default-extensions: OverloadedStrings
23+ ghc-options: -Wall
24+ build-depends: aeson >= 0.8 && < 0.9
25+ , base >= 4.7 && < 4.8
26+ , bytestring >= 0.10 && < 0.11
27+ , hashable >= 1.2 && < 1.3
28+ , lens >= 4.7 && < 4.8
29+ , regexpr >= 0.5 && < 0.6
30+ , scientific >= 0.3 && < 0.4
31+ , unordered-containers >= 0.2 && < 0.3
32+ , text >= 1.2 && < 1.3
33+ , vector >= 0.10 && < 0.11
34+ , wreq >= 0.3 && < 0.4
35+
36+test-suite official
37+ type: exitcode-stdio-1.0
38+ hs-source-dirs: tests
39+ main-is: Test.hs
40+ default-language: Haskell2010
41+ ghc-options: -Wall
42+ default-extensions: OverloadedStrings
43+ build-depends: aeson
44+ , base
45+ , bytestring
46+ , hjsonschema
47+ , unordered-containers
48+ , text
49+ , vector
50+ , directory >= 1.2 && < 1.3
51+ , filepath >= 1.3 && < 1.4
52+ , HUnit >= 1.2 && < 1.3
53+ , test-framework >= 0.8 && < 0.9
54+ , test-framework-hunit >= 0.3 && < 0.4
55+
56+source-repository head
57+ type: git
58+ location: git://github.com/seagreen/hjsonschema.git
src/Data/JsonSchema.hsnew file+80
@@ -0,0 +1,80 @@
1+module Data.JsonSchema
2+ ( module Data.JsonSchema
3+ , module Data.JsonSchema.Core
4+ ) where
5+
6+import Control.Applicative
7+import Data.Aeson
8+import Data.Foldable
9+import qualified Data.HashMap.Strict as H
10+import Data.JsonSchema.Core
11+import Data.JsonSchema.JsonReference
12+import Data.JsonSchema.Utils
13+import Data.JsonSchema.Validators
14+import Data.Maybe
15+import Data.Text (Text)
16+import qualified Data.Text as T
17+import Data.Vector (Vector)
18+import qualified Data.Vector as V
19+import Prelude hiding (foldr)
20+
21+draft4 :: Spec
22+draft4 = Spec $ H.fromList
23+ [ ("$ref", ref)
24+ , ("multipleOf", multipleOf)
25+ , ("maximum", maximumVal)
26+ , ("minimum", minimumVal)
27+ , ("maxLength", maxLength)
28+ , ("minLength", minLength)
29+ , ("pattern", pattern)
30+ , ("items", items)
31+ , ("maxItems", maxItems)
32+ , ("minItems", minItems)
33+ , ("uniqueItems", uniqueItems)
34+ , ("maxProperties", maxProperties)
35+ , ("minProperties", minProperties)
36+ , ("required", required)
37+ , ("properties", properties)
38+ , ("patternProperties", patternProperties)
39+ , ("additionalProperties", additionalProperties)
40+ , ("dependencies", dependencies)
41+ , ("enum", enum)
42+ , ("type", typeVal)
43+ , ("allOf", allOf)
44+ , ("anyOf", anyOf)
45+ , ("oneOf", oneOf)
46+ , ("not", notValidator)
47+ ]
48+
49+fetchRefs :: RawSchema -> Graph -> IO Graph
50+fetchRefs a graph =
51+ let newGraph = H.insert (_rsURI a) (_rsObject a) graph
52+ rSchema = allEmbedded (_rsURI a, Object $ _rsObject a) V.empty
53+ in foldlM fetch newGraph rSchema
54+
55+ where
56+ -- TODO: optimize
57+ allEmbedded :: (Text, Value) -> Vector RawSchema -> Vector RawSchema
58+ allEmbedded (t, Object o) rs =
59+ let t' = updateId t o
60+ r = RawSchema t' o
61+ ns = (\x -> (t',x)) <$> V.fromList (H.elems o)
62+ in foldr allEmbedded (V.snoc rs r) ns
63+ allEmbedded (t, Array vs) rs =
64+ let ns = (\x -> (t,x)) <$> vs
65+ in foldr allEmbedded rs ns
66+ allEmbedded _ rs = rs
67+
68+ fetch :: Graph -> RawSchema -> IO Graph
69+ fetch g r =
70+ case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndP of
71+ Nothing -> return g
72+ Just (s, _) ->
73+ let t = (_rsURI r `combineIdAndRef` s)
74+ in if T.length t <= 0 || H.member t g || not ("://" `T.isInfixOf` t)
75+ then return g
76+ else do
77+ eResp <- fetchRef t
78+ case eResp of
79+ Right obj -> fetchRefs (RawSchema t obj) g
80+ _ -> return g
src/Data/JsonSchema/Core.hsnew file+38
@@ -0,0 +1,38 @@
1+module Data.JsonSchema.Core where
2+
3+import Data.Aeson
4+import Data.HashMap.Strict (HashMap)
5+import qualified Data.HashMap.Strict as H
6+import Data.JsonSchema.JsonReference
7+import Data.Maybe
8+import Data.Text (Text)
9+import Data.Vector (Vector)
10+import qualified Data.Vector as V
11+
12+newtype Spec = Spec { _unSpec :: HashMap Text ValidatorGen }
13+
14+-- | Set of potentially mutually recursive schemas.
15+type Graph = HashMap Text (HashMap Text Value)
16+
17+type ValErr = Text
18+
19+type Validator = Value -> Vector ValErr
20+
21+type ValidatorGen = Spec -> Graph -> RawSchema -> Value -> Maybe Validator
22+
23+type Schema = Vector Validator
24+
25+data RawSchema = RawSchema
26+ { _rsURI :: Text
27+ , _rsObject :: HashMap Text Value
28+ }
29+
30+compile :: Spec -> Graph -> RawSchema -> Schema
31+compile spec g (RawSchema t o) =
32+ V.fromList . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o
33+ where
34+ f :: ValidatorGen -> Value -> Maybe Validator
35+ f vGen = vGen spec g $ RawSchema (updateId t o) o
36+
37+validate :: Schema -> Value -> Vector ValErr
38+validate s x = s >>= ($ x)
src/Data/JsonSchema/JsonReference.hsnew file+92
@@ -0,0 +1,92 @@
1+module Data.JsonSchema.JsonReference where
2+
3+-- | There should be a JSON Reference library for haskell.
4+
5+import Control.Exception
6+import Control.Lens
7+import Control.Monad
8+import Data.Aeson
9+import Data.ByteString.Lazy (ByteString)
10+import Data.HashMap.Strict (HashMap)
11+import qualified Data.HashMap.Strict as H
12+import Data.Monoid
13+import Data.Text (Text)
14+import qualified Data.Text as T
15+import qualified Data.Vector as V
16+import Network.Wreq
17+import Prelude hiding (foldr)
18+import Text.Read (readMaybe)
19+
20+combineIdAndRef :: Text -> Text -> Text
21+combineIdAndRef a b
22+ | "://" `T.isInfixOf` b = b
23+ | T.length a < 1 || T.length b < 1 = a <> b
24+ | T.last a == '#' && T.head b == '#' = a <> T.tail b
25+ | otherwise = a <> b
26+
27+combineIds :: Text -> Text -> Text
28+combineIds a b
29+ | b == "#" || b == "" = a
30+ | "://" `T.isInfixOf` b = b
31+ | T.length a < 1 || T.length b < 1 = a <> b
32+ | T.last a == '#' && T.head b == '#' = a <> T.tail b
33+ | otherwise = a <> b
34+
35+updateId :: Text -> HashMap Text Value -> Text
36+updateId t o =
37+ case H.lookup "id" o of
38+ Just (String idVal) -> t `combineIds` idVal
39+ _ -> t
40+
41+refAndP :: Text -> Maybe (Text, Text)
42+refAndP val = getParts $ T.splitOn "#" val
43+ where
44+ getParts :: [Text] -> Maybe (Text, Text)
45+ getParts [] = Just ("","")
46+ getParts [x] = Just (x,"")
47+ getParts [x,y] = Just (x,y)
48+ getParts _ = Nothing
49+
50+fetchRef :: Text -> IO (Either Text (HashMap Text Value))
51+fetchRef t = do
52+ eResp <- safeGet t
53+ case eResp of
54+ Left _ -> return (Left "TODO")
55+ Right b ->
56+ case decode b of
57+ Just (Object z) -> return (Right z)
58+ _ -> return (Left "TODO")
59+
60+safeGet :: Text -> IO (Either Text ByteString)
61+safeGet url =
62+ catch
63+ (return . Right . (^. responseBody) =<< get (T.unpack url))
64+ handler
65+ where
66+ handler :: SomeException -> IO (Either Text ByteString)
67+ handler e = return . Left . T.pack . show $ e
68+
69+-- | There should be a JSON Pointer library.
70+--
71+-- Spec: http://tools.ietf.org/html/draft-ietf-appsawg-json-pointer-07
72+jsonPointer :: Text -> Value -> Maybe Value
73+jsonPointer pntr = resolve (T.splitOn "/" pntr)
74+ where
75+ resolve :: [Text] -> Value -> Maybe Value
76+ resolve (referenceToken:ts) a =
77+ let t = unescape referenceToken
78+ in case T.length t of
79+ 0 -> resolve ts a
80+ _ ->
81+ case a of
82+ (Object b) -> H.lookup t b >>= resolve ts
83+ (Array c) -> do
84+ n <- readMaybe (T.unpack t)
85+ when (n < 0 || n + 1 > V.length c) Nothing
86+ resolve ts (c V.! n)
87+ _ -> Nothing
88+ resolve _ a = Just a
89+
90+ -- TODO: do more things need to be escaped?
91+ unescape :: Text -> Text
92+ unescape t = T.replace "%25" "%" $ T.replace "~0" "~" $ T.replace "~1" "/" t
src/Data/JsonSchema/Utils.hsnew file+73
@@ -0,0 +1,73 @@
1+{-# LANGUAGE OverloadedLists #-}
2+
3+module Data.JsonSchema.Utils where
4+
5+import Data.Aeson
6+import Data.HashMap.Strict (HashMap)
7+import Data.JsonSchema.Core
8+import Data.List
9+import Data.Monoid
10+import Data.Scientific
11+import Data.Text (Text)
12+import qualified Data.Text as T
13+import Data.Vector (Vector)
14+import qualified Data.Vector as V
15+
16+isJsonType :: Value -> Vector Text -> Vector ValErr
17+isJsonType x xs =
18+ case x of
19+ (Null) -> f "null" xs ("null" :: Text)
20+ (Array y) -> f "array" xs y
21+ (Bool y) -> f "boolean" xs y
22+ (Object y) -> f "object" xs y
23+ (String y) -> f "string" xs y
24+ (Number y) ->
25+ case toBoundedInteger y :: Maybe Int of
26+ Nothing -> f "number" xs y
27+ Just _ -> if V.elem "number" xs || V.elem "integer" xs
28+ then mempty
29+ else mkErr y xs
30+ where
31+ f :: (Show a) => Text -> Vector Text -> a -> Vector ValErr
32+ f t ts d = if V.elem t ts then mempty else mkErr d ts
33+
34+ mkErr :: (Show a) => a -> Vector Text -> Vector ValErr
35+ mkErr y ts = V.singleton $ tshow y <> " is not one of the types " <> tshow ts
36+
37+runMaybeVal :: Maybe Validator -> Value -> Vector ValErr
38+runMaybeVal Nothing _ = mempty
39+runMaybeVal (Just val) d = val d
40+
41+runMaybeVal'
42+ :: Maybe (Value -> (Vector ValErr, Value))
43+ -> Value
44+ -> (Vector ValErr, Value)
45+runMaybeVal' Nothing d = (mempty, d)
46+runMaybeVal' (Just val) d = val d
47+
48+-- TODO: optimize
49+-- see here: http://comments.gmane.org/gmane.comp.lang.haskell.cafe/106242
50+allUnique :: (Eq a) => Vector a -> Bool
51+allUnique bs = length (nub (V.toList bs)) == V.length bs
52+
53+-- TODO: optimize
54+count :: (Eq a) => a -> Vector a -> Int
55+count b bs = V.length $ V.filter (== b) bs
56+
57+toObj :: Value -> Maybe (HashMap Text Value)
58+toObj (Object a) = Just a
59+toObj _ = Nothing
60+
61+fromJSONInt :: Value -> Maybe Int
62+fromJSONInt (Number n) = toBoundedInteger n
63+fromJSONInt _ = Nothing
64+
65+toTxt :: Value -> Maybe Text
66+toTxt (String t) = Just t
67+toTxt _ = Nothing
68+
69+greaterThanZero :: (Num a, Ord a) => a -> Maybe ()
70+greaterThanZero n = if n <= 0 then Nothing else Just ()
71+
72+tshow :: Show a => a -> Text
73+tshow = T.pack . show
src/Data/JsonSchema/Validators.hsnew file+497
@@ -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
tests/Test.hsnew file+91
@@ -0,0 +1,91 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Main where
4+
5+import Control.Applicative
6+import Control.Monad
7+import Data.Aeson
8+import Data.Aeson.TH
9+import qualified Data.ByteString.Lazy as LBS
10+import Data.Char (toLower)
11+import qualified Data.HashMap.Strict as H
12+import Data.JsonSchema
13+import Data.List (isSuffixOf)
14+import Data.Monoid
15+import Data.Text (Text)
16+import qualified Data.Text as T
17+import qualified Data.Vector as V
18+import System.Directory (getDirectoryContents)
19+import System.FilePath ((</>))
20+import Test.Framework
21+import Test.Framework.Providers.HUnit
22+import qualified Test.HUnit as HU
23+
24+main :: IO ()
25+main = do
26+ ts <- readSchemaTests
27+ defaultMain (toTest <$> ts)
28+
29+data SchemaTest = SchemaTest
30+ { _stDescription :: Text
31+ , _stSchema :: RawSchema
32+ , _stCases :: [SchemaTestCase]
33+ }
34+
35+data SchemaTestCase = SchemaTestCase
36+ { _scDescription :: Text
37+ , _scData :: Value
38+ , _scValid :: Bool
39+ }
40+
41+instance FromJSON RawSchema where
42+ parseJSON = withObject "Schema" $ \o ->
43+ return $ RawSchema "" o
44+
45+instance FromJSON SchemaTest where
46+ parseJSON = withObject "SchemaTest" $ \o -> SchemaTest
47+ <$> o .: "description"
48+ <*> o .: "schema"
49+ <*> o .: "tests" -- I wish this were "cases"
50+
51+readSchemaTests :: IO [SchemaTest]
52+readSchemaTests = do
53+ jsonFiles <- filter (".json" `isSuffixOf`) <$> getDirectoryContents dir
54+ fmap concat $ forM jsonFiles $ \file -> do
55+ let fullPath = dir </> file
56+ jsonBS <- LBS.readFile fullPath
57+ case eitherDecode jsonBS of
58+ Left err -> fail $ "couldn't parse file '" <> fullPath <> "': " <> err
59+ Right schemas -> return $ prependFileName file <$> schemas
60+ where
61+ dir = "JSON-Schema-Test-Suite/tests/draft4"
62+ prependFileName :: String -> SchemaTest -> SchemaTest
63+ prependFileName fileName s = s
64+ { _stDescription = T.pack fileName <> ": " <> _stDescription s
65+ }
66+
67+toTest :: SchemaTest -> Test
68+toTest st = testGroup groupName (mkCase <$> _stCases st)
69+ where
70+ groupName :: String
71+ groupName = T.unpack $ _stDescription st
72+
73+ mkCase :: SchemaTestCase -> Test
74+ mkCase sc = testCase caseName assertion
75+ where
76+ caseName = T.unpack $ _scDescription sc
77+ assertion = if _scValid sc
78+ then assertValid (_stSchema st) (_scData sc)
79+ else assertInvalid (_stSchema st) (_scData sc)
80+
81+assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion
82+assertValid r v = do
83+ g <- fetchRefs r H.empty
84+ let es = validate (compile draft4 g r) v
85+ unless (V.length es == 0) $ HU.assertFailure (show es)
86+assertInvalid r v = do
87+ g <- fetchRefs r H.empty
88+ let es = validate (compile draft4 g r) v
89+ when (V.length es == 0) $ HU.assertFailure "expected a validation error"
90+
91+$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)