hjsonschema (empty) → 0.1.0.0
raw patch · 10 files changed
+983/−0 lines, 10 filesdep +HUnitdep +aesondep +basesetup-changed
Dependencies added: HUnit, aeson, base, bytestring, directory, filepath, hashable, hjsonschema, lens, regexpr, scientific, test-framework, test-framework-hunit, text, unordered-containers, vector, wreq
Files
- MIT-LICENSE.txt +20/−0
- README.md +32/−0
- Setup.hs +2/−0
- hjsonschema.cabal +58/−0
- src/Data/JsonSchema.hs +80/−0
- src/Data/JsonSchema/Core.hs +38/−0
- src/Data/JsonSchema/JsonReference.hs +92/−0
- src/Data/JsonSchema/Utils.hs +73/−0
- src/Data/JsonSchema/Validators.hs +497/−0
- tests/Test.hs +91/−0
+ MIT-LICENSE.txt view
@@ -0,0 +1,20 @@+The MIT License (MIT)+Copyright (c) 2015 Ian Grant Jeffries++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE+OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,32 @@+# Intro++An implementation of [JSON Schema](http://json-schema.org/) v4 in haskell.++# Status++Still in development. Lacks documentation, example code, and real error messages.++Also while all the official tests pass, its implementation of the `$ref` and `id` keywords is incomplete.++# Install Tests++ git submodule update --init++# Run Tests++ cd JSON-Schema-Test-Suite/remotes+ python -m SimpleHTTPServer 1234++Then run the normal `cabal test` from another terminal.++Note that the tests require an internet connection.++# Notes++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.++# Credits++Thanks to [Julian Berman](https://github.com/Julian) for the fantastic test suite.++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.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hjsonschema.cabal view
@@ -0,0 +1,58 @@+name: hjsonschema+version: 0.1.0.0+synopsis: Haskell implementation of JSON Schema v4.+homepage: https://github.com/seagreen/hjsonschema+license: MIT+license-file: MIT-LICENSE.txt+author: Ian Grant Jeffries+maintainer: ian@housejeffries.com+category: Data+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.JsonSchema+ , Data.JsonSchema.JsonReference+ , Data.JsonSchema.Utils+ , Data.JsonSchema.Validators+ other-modules: Data.JsonSchema.Core+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ ghc-options: -Wall+ build-depends: aeson >= 0.8 && < 0.9+ , base >= 4.7 && < 4.8+ , bytestring >= 0.10 && < 0.11+ , hashable >= 1.2 && < 1.3+ , lens >= 4.7 && < 4.8+ , regexpr >= 0.5 && < 0.6+ , scientific >= 0.3 && < 0.4+ , unordered-containers >= 0.2 && < 0.3+ , text >= 1.2 && < 1.3+ , vector >= 0.10 && < 0.11+ , wreq >= 0.3 && < 0.4++test-suite official+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Test.hs+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions: OverloadedStrings+ build-depends: aeson+ , base+ , bytestring+ , hjsonschema+ , unordered-containers+ , text+ , vector+ , directory >= 1.2 && < 1.3+ , filepath >= 1.3 && < 1.4+ , HUnit >= 1.2 && < 1.3+ , test-framework >= 0.8 && < 0.9+ , test-framework-hunit >= 0.3 && < 0.4++source-repository head+ type: git+ location: git://github.com/seagreen/hjsonschema.git
+ src/Data/JsonSchema.hs view
@@ -0,0 +1,80 @@+module Data.JsonSchema+ ( module Data.JsonSchema+ , module Data.JsonSchema.Core+ ) where++import Control.Applicative+import Data.Aeson+import Data.Foldable+import qualified Data.HashMap.Strict as H+import Data.JsonSchema.Core+import Data.JsonSchema.JsonReference+import Data.JsonSchema.Utils+import Data.JsonSchema.Validators+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector (Vector)+import qualified Data.Vector as V+import Prelude hiding (foldr)++draft4 :: Spec+draft4 = Spec $ H.fromList+ [ ("$ref", ref)+ , ("multipleOf", multipleOf)+ , ("maximum", maximumVal)+ , ("minimum", minimumVal)+ , ("maxLength", maxLength)+ , ("minLength", minLength)+ , ("pattern", pattern)+ , ("items", items)+ , ("maxItems", maxItems)+ , ("minItems", minItems)+ , ("uniqueItems", uniqueItems)+ , ("maxProperties", maxProperties)+ , ("minProperties", minProperties)+ , ("required", required)+ , ("properties", properties)+ , ("patternProperties", patternProperties)+ , ("additionalProperties", additionalProperties)+ , ("dependencies", dependencies)+ , ("enum", enum)+ , ("type", typeVal)+ , ("allOf", allOf)+ , ("anyOf", anyOf)+ , ("oneOf", oneOf)+ , ("not", notValidator)+ ]++fetchRefs :: RawSchema -> Graph -> IO Graph+fetchRefs a graph =+ let newGraph = H.insert (_rsURI a) (_rsObject a) graph+ rSchema = allEmbedded (_rsURI a, Object $ _rsObject a) V.empty+ in foldlM fetch newGraph rSchema++ where+ -- TODO: optimize+ allEmbedded :: (Text, Value) -> Vector RawSchema -> Vector RawSchema+ allEmbedded (t, Object o) rs =+ let t' = updateId t o+ r = RawSchema t' o+ ns = (\x -> (t',x)) <$> V.fromList (H.elems o)+ in foldr allEmbedded (V.snoc rs r) ns+ allEmbedded (t, Array vs) rs =+ let ns = (\x -> (t,x)) <$> vs+ in foldr allEmbedded rs ns+ allEmbedded _ rs = rs++ fetch :: Graph -> RawSchema -> IO Graph+ fetch g r =+ case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndP of+ Nothing -> return g+ Just (s, _) ->+ let t = (_rsURI r `combineIdAndRef` s)+ in if T.length t <= 0 || H.member t g || not ("://" `T.isInfixOf` t)+ then return g+ else do+ eResp <- fetchRef t+ case eResp of+ Right obj -> fetchRefs (RawSchema t obj) g+ _ -> return g
+ src/Data/JsonSchema/Core.hs view
@@ -0,0 +1,38 @@+module Data.JsonSchema.Core where++import Data.Aeson+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.JsonSchema.JsonReference+import Data.Maybe+import Data.Text (Text)+import Data.Vector (Vector)+import qualified Data.Vector as V++newtype Spec = Spec { _unSpec :: HashMap Text ValidatorGen }++-- | Set of potentially mutually recursive schemas.+type Graph = HashMap Text (HashMap Text Value)++type ValErr = Text++type Validator = Value -> Vector ValErr++type ValidatorGen = Spec -> Graph -> RawSchema -> Value -> Maybe Validator++type Schema = Vector Validator++data RawSchema = RawSchema+ { _rsURI :: Text+ , _rsObject :: HashMap Text Value+ }++compile :: Spec -> Graph -> RawSchema -> Schema+compile spec g (RawSchema t o) =+ V.fromList . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o+ where+ f :: ValidatorGen -> Value -> Maybe Validator+ f vGen = vGen spec g $ RawSchema (updateId t o) o++validate :: Schema -> Value -> Vector ValErr+validate s x = s >>= ($ x)
+ src/Data/JsonSchema/JsonReference.hs view
@@ -0,0 +1,92 @@+module Data.JsonSchema.JsonReference where++-- | There should be a JSON Reference library for haskell.++import Control.Exception+import Control.Lens+import Control.Monad+import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import Network.Wreq+import Prelude hiding (foldr)+import Text.Read (readMaybe)++combineIdAndRef :: Text -> Text -> Text+combineIdAndRef a b+ | "://" `T.isInfixOf` b = b+ | T.length a < 1 || T.length b < 1 = a <> b+ | T.last a == '#' && T.head b == '#' = a <> T.tail b+ | otherwise = a <> b++combineIds :: Text -> Text -> Text+combineIds a b+ | b == "#" || b == "" = a+ | "://" `T.isInfixOf` b = b+ | T.length a < 1 || T.length b < 1 = a <> b+ | T.last a == '#' && T.head b == '#' = a <> T.tail b+ | otherwise = a <> b++updateId :: Text -> HashMap Text Value -> Text+updateId t o =+ case H.lookup "id" o of+ Just (String idVal) -> t `combineIds` idVal+ _ -> t++refAndP :: Text -> Maybe (Text, Text)+refAndP val = getParts $ T.splitOn "#" val+ where+ getParts :: [Text] -> Maybe (Text, Text)+ getParts [] = Just ("","")+ getParts [x] = Just (x,"")+ getParts [x,y] = Just (x,y)+ getParts _ = Nothing++fetchRef :: Text -> IO (Either Text (HashMap Text Value))+fetchRef t = do+ eResp <- safeGet t+ case eResp of+ Left _ -> return (Left "TODO")+ Right b ->+ case decode b of+ Just (Object z) -> return (Right z)+ _ -> return (Left "TODO")++safeGet :: Text -> IO (Either Text ByteString)+safeGet url =+ catch+ (return . Right . (^. responseBody) =<< get (T.unpack url))+ handler+ where+ handler :: SomeException -> IO (Either Text ByteString)+ handler e = return . Left . T.pack . show $ e++-- | There should be a JSON Pointer library.+--+-- Spec: http://tools.ietf.org/html/draft-ietf-appsawg-json-pointer-07+jsonPointer :: Text -> Value -> Maybe Value+jsonPointer pntr = resolve (T.splitOn "/" pntr)+ where+ resolve :: [Text] -> Value -> Maybe Value+ resolve (referenceToken:ts) a =+ let t = unescape referenceToken+ in case T.length t of+ 0 -> resolve ts a+ _ ->+ case a of+ (Object b) -> H.lookup t b >>= resolve ts+ (Array c) -> do+ n <- readMaybe (T.unpack t)+ when (n < 0 || n + 1 > V.length c) Nothing+ resolve ts (c V.! n)+ _ -> Nothing+ resolve _ a = Just a++ -- TODO: do more things need to be escaped?+ unescape :: Text -> Text+ unescape t = T.replace "%25" "%" $ T.replace "~0" "~" $ T.replace "~1" "/" t
+ src/Data/JsonSchema/Utils.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedLists #-}++module Data.JsonSchema.Utils where++import Data.Aeson+import Data.HashMap.Strict (HashMap)+import Data.JsonSchema.Core+import Data.List+import Data.Monoid+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector (Vector)+import qualified Data.Vector as V++isJsonType :: Value -> Vector Text -> Vector ValErr+isJsonType x xs =+ case x of+ (Null) -> f "null" xs ("null" :: Text)+ (Array y) -> f "array" xs y+ (Bool y) -> f "boolean" xs y+ (Object y) -> f "object" xs y+ (String y) -> f "string" xs y+ (Number y) ->+ case toBoundedInteger y :: Maybe Int of+ Nothing -> f "number" xs y+ Just _ -> if V.elem "number" xs || V.elem "integer" xs+ then mempty+ else mkErr y xs+ where+ f :: (Show a) => Text -> Vector Text -> a -> Vector ValErr+ f t ts d = if V.elem t ts then mempty else mkErr d ts++ mkErr :: (Show a) => a -> Vector Text -> Vector ValErr+ mkErr y ts = V.singleton $ tshow y <> " is not one of the types " <> tshow ts++runMaybeVal :: Maybe Validator -> Value -> Vector ValErr+runMaybeVal Nothing _ = mempty+runMaybeVal (Just val) d = val d++runMaybeVal'+ :: Maybe (Value -> (Vector ValErr, Value))+ -> Value+ -> (Vector ValErr, Value)+runMaybeVal' Nothing d = (mempty, d)+runMaybeVal' (Just val) d = val d++-- TODO: optimize+-- see here: http://comments.gmane.org/gmane.comp.lang.haskell.cafe/106242+allUnique :: (Eq a) => Vector a -> Bool+allUnique bs = length (nub (V.toList bs)) == V.length bs++-- TODO: optimize+count :: (Eq a) => a -> Vector a -> Int+count b bs = V.length $ V.filter (== b) bs++toObj :: Value -> Maybe (HashMap Text Value)+toObj (Object a) = Just a+toObj _ = Nothing++fromJSONInt :: Value -> Maybe Int+fromJSONInt (Number n) = toBoundedInteger n+fromJSONInt _ = Nothing++toTxt :: Value -> Maybe Text+toTxt (String t) = Just t+toTxt _ = Nothing++greaterThanZero :: (Num a, Ord a) => a -> Maybe ()+greaterThanZero n = if n <= 0 then Nothing else Just ()++tshow :: Show a => a -> Text+tshow = T.pack . show
+ src/Data/JsonSchema/Validators.hs view
@@ -0,0 +1,497 @@+{-# LANGUAGE OverloadedLists #-}++-- | This is generally meant to be an internal module.+-- It's only exposed in case you want to make your own+-- 'Spec'. If you just want to use JSON Schema Draft 4+-- use the preassembled 'Data.JsonSchema.draft4' instead.+--+-- This module exposes three types of functions. To describe+-- them we'll use the properties validators as an example.+--+-- 1. Functions that aren't followed by apostrophes have the+-- type 'ValidatorGen' and are meant to be used in a 'Spec'.+-- Examples are 'properties' and 'additionalProperties'.+--+-- 2. Functions that are followed by a single apostrophe, such+-- as 'additionalProperties'', aren't meant to be used standalone+-- in a 'Spec'. Instead they're used by other validators. For+-- instance, 'additionalProperties' disables itself if the key+-- "properties" is present to allow 'additionalProperties' to+-- handle its validation. Placing the actual meat of+-- 'additionalProperties' in 'additionalProperties'' allows for+-- code reuse between 'properties' and 'additionalProperties'.+--+-- 3. Functions that are followed by a double apostrophe, such+-- as 'patternProperties''', return an enhanced validator. It+-- not only reports errors, but also the parts of the target+-- data that it matches. These functions also aren't used in+-- a 'Spec' instance, but are necessary helpers for actual+-- validators in certain situations.++module Data.JsonSchema.Validators where++import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.Fixed (mod')+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H+import Data.JsonSchema.Core+import Data.JsonSchema.JsonReference+import Data.JsonSchema.Utils+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Data.Traversable+import Data.Vector (Vector)+import qualified Data.Vector as V+import Text.RegexPR++--------------------------------------------------+-- Number Validators+--------------------------------------------------++multipleOf :: ValidatorGen+multipleOf _ _ _ (Number val) = do+ greaterThanZero val+ Just (\x ->+ case x of+ (Number y) -> if y `mod'` val /= 0+ then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val+ else mempty+ _ -> mempty)+multipleOf _ _ _ _ = Nothing++maximumVal :: ValidatorGen+maximumVal _ _ s (Number val) =+ let f = case H.lookup "exclusiveMaximum" (_rsObject s) of+ Just (Bool a) -> if a then (>=) else (>)+ _ -> (>)+ in Just (\x ->+ case x of+ (Number y) -> if y `f` val+ then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val+ else mempty+ _ -> mempty)+maximumVal _ _ _ _ = Nothing++minimumVal :: ValidatorGen+minimumVal _ _ s (Number val) =+ let f = case H.lookup "exclusiveMinimum" (_rsObject s) of+ Just (Bool a) -> if a then (<=) else (<)+ _ -> (<)+ in Just (\x ->+ case x of+ (Number y) -> if y `f` val+ then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val+ else mempty+ _ -> mempty)+minimumVal _ _ _ _ = Nothing++--------------------------------------------------+-- String Validators+--------------------------------------------------++maxLength :: ValidatorGen+maxLength _ _ _ v = do+ val <- fromJSONInt v+ greaterThanZero val+ Just (\x ->+ case x of+ (String y) -> if T.length y > val+ then V.singleton $ y <> " is greater than maxLength " <> tshow val+ else mempty+ _ -> mempty)++minLength :: ValidatorGen+minLength _ _ _ v = do+ val <- fromJSONInt v+ greaterThanZero val+ Just (\x ->+ case x of+ (String y) -> if T.length y < val+ then V.singleton $ y <> " is less than minLength " <> tshow val+ else mempty+ _ -> mempty)++pattern :: ValidatorGen+pattern _ _ _ (String val) =+ Just (\x ->+ case x of+ (String t) ->+ case matchRegexPR (T.unpack val) (T.unpack t) of+ Nothing -> V.singleton $ t <> " fails to validate against pattern " <> val+ Just _ -> mempty+ _ -> mempty)+pattern _ _ _ _ = Nothing++--------------------------------------------------+-- Array Validators+--------------------------------------------------++-- | Also covers additionalItems.+--+-- We can leave additionalItems out of the spec HashMap, since items defaults to {},+-- and if it isn't present additionalItems will always validate successfully.+items :: ValidatorGen+items spec g s (Object val) =+ let sub = compile spec g (RawSchema (_rsURI s) val)+ in Just (\x ->+ case x of+ (Array ys) -> ys >>= validate sub+ _ -> mempty)+items spec g s (Array vs) = do+ os <- traverse toObj vs+ let ss = compile spec g . RawSchema (_rsURI s) <$> os+ let addItems = do+ a <- H.lookup "additionalItems" (_rsObject s)+ additionalItems' spec g s a+ Just (\x ->+ case x of+ (Array ys) ->+ let extras = V.drop (V.length os) ys+ in join (V.zipWith validate ss ys) <> runMaybeVal addItems (Array extras)+ _ -> mempty)+items _ _ _ _ = Nothing++additionalItems' :: ValidatorGen+additionalItems' _ _ _ (Bool val) =+ Just (\x ->+ case x of+ (Array ys) -> if not val && V.length ys > 0+ then V.singleton "TODO"+ else mempty+ _ -> mempty)+additionalItems' spec g s (Object val) =+ let sub = compile spec g (RawSchema (_rsURI s) val)+ in Just (\x ->+ case x of+ (Array ys) -> ys >>= validate sub+ _ -> mempty)+additionalItems' _ _ _ _ = Nothing++maxItems :: ValidatorGen+maxItems _ _ _ v = do+ val <- fromJSONInt v+ greaterThanZero val+ Just (\x ->+ case x of+ (Array ys) -> if V.length ys > val+ then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val+ else mempty+ _ -> mempty)++minItems :: ValidatorGen+minItems _ _ _ v = do+ val <- fromJSONInt v+ greaterThanZero val+ Just (\x ->+ case x of+ (Array ys) -> if V.length ys < val+ then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val+ else mempty+ _ -> mempty)++uniqueItems :: ValidatorGen+uniqueItems _ _ _ (Bool val) = do+ unless val Nothing+ Just (\x ->+ case x of+ (Array ys) -> if allUnique ys+ then mempty+ else V.singleton "TODO"+ _ -> mempty)+uniqueItems _ _ _ _ = Nothing++--------------------------------------------------+-- Object Validators+--------------------------------------------------++maxProperties :: ValidatorGen+maxProperties _ _ _ v = do+ val <- fromJSONInt v+ greaterThanZero val+ Just (\x ->+ case x of+ (Object o) -> if H.size o > val+ then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val+ else mempty+ _ -> mempty)++minProperties :: ValidatorGen+minProperties _ _ _ v = do+ val <- fromJSONInt v+ greaterThanZero val+ Just (\x ->+ case x of+ (Object o) -> if H.size o < val+ then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val+ else mempty+ _ -> mempty)++required :: ValidatorGen+required _ _ _ (Array vs) = do+ when (V.length vs == 0) Nothing+ ts <- traverse toTxt vs+ let a = vectorToMap ts+ when (H.size a /= V.length ts) Nothing+ Just (\x ->+ case x of+ (Object o) -> if H.size (H.difference a o) > 0+ then V.singleton $ "the keys of " <> tshow o+ <> " don't contain all the required elements " <> tshow vs+ else mempty+ _ -> mempty)+ where+ -- TODO: optimize+ vectorToMap :: (Eq a, Hashable a) => Vector a -> HashMap a Bool+ vectorToMap vec = H.fromList $ zip (V.toList vec) (repeat True)+required _ _ _ _ = Nothing++-- TODO: Fix up the properties* validators. They're all a huge mess, but at least+-- they work.+--+-- In order of what's tried: properties, patternProperties, additionalProperties+properties :: ValidatorGen+properties spec g s v = do+ let mProps = properties'' spec g s v+ let mPatProp = do+ aV <- H.lookup "patternProperties" (_rsObject s)+ patternProperties'' spec g s aV+ let mAdd = do+ aVal <- H.lookup "additionalProperties" (_rsObject s)+ additionalProperties' spec g s aVal+ when (isNothing mProps && isNothing mPatProp && isNothing mAdd) Nothing+ Just (\x ->+ case x of+ (Object y) -> -- Got myself into a mess here.+ let (e1s, remaining) = runMaybeVal' mProps (Object y)+ (_, remaining') = runMaybeVal' mPatProp remaining+ (e2s, _) = runMaybeVal' mPatProp (Object y)+ in e1s <> e2s <> runMaybeVal mAdd remaining'+ _ -> mempty)++-- TODO: optimize+properties''+ :: Spec+ -> Graph+ -> RawSchema+ -> Value+ -> Maybe (Value -> (Vector ValErr, Value))+properties'' spec g s (Object val) = do+ os <- traverse toObj val+ let oss = compile spec g . RawSchema (_rsURI s) <$> os+ Just (\x ->+ case x of+ (Object y) -> ( join . V.fromList . H.elems $ H.intersectionWith validate oss y+ , Object (H.difference y oss))+ z -> (mempty, z))+properties'' _ _ _ _ = Nothing++-- TODO: optimize+patternProperties''+ :: Spec+ -> Graph+ -> RawSchema+ -> Value+ -> Maybe (Value -> (Vector ValErr, Value))+patternProperties'' spec g s (Object val) = do+ os <- traverse toObj val+ let vs = compile spec g . RawSchema (_rsURI s) <$> os+ Just (\x ->+ case x of+ (Object y) -> let ms = matches (V.fromList . H.toList $ vs) <$> (V.fromList . H.toList $ y)+ in (ms >>= runVals, leftovers ms)+ _ -> (mempty, x))+ where+ matches :: Vector (Text, Schema) -> (Text, Value) -> (Text, Value, Vector Schema)+ matches ss (k, v) = (k, v, ss >>= match k)++ match :: Text -> (Text, Schema) -> Vector Schema+ match k (r, sc) =+ case matchRegexPR (T.unpack r) (T.unpack k) of+ Nothing -> mempty+ Just _ -> V.singleton sc++ runVals :: (Text, Value, Vector Schema) -> Vector ValErr+ runVals (_,v,ss) = join $ validate <$> ss <*> pure v++ leftovers :: Vector (Text, Value, Vector Schema) -> Value+ leftovers possiblyMatched =+ let unmatched = V.filter (\(_,_,ss) -> V.length ss == 0) possiblyMatched+ in Object . H.fromList . V.toList $ (\(v,k,_) -> (v,k)) <$> unmatched++patternProperties'' _ _ _ _ = Nothing++patternProperties :: ValidatorGen+patternProperties spec g s v = do+ when (H.member "properties" (_rsObject s)) Nothing+ let mPatProp = patternProperties'' spec g s v+ -- TODO: checking additionalProperties as well doesn't help with tests+ let mAdd = do+ aVal <- H.lookup "additionalProperties" (_rsObject s)+ additionalProperties' spec g s aVal+ when (isNothing mPatProp && isNothing mAdd) Nothing+ Just (\x ->+ case x of+ (Object y) ->+ let (e2s, remaining') = runMaybeVal' mPatProp (Object y)+ in e2s <> runMaybeVal mAdd remaining'+ _ -> mempty)++additionalProperties' :: ValidatorGen+additionalProperties' _ _ _ (Bool val) =+ Just (\x ->+ case x of+ (Object y) -> if val || H.size y == 0+ then mempty+ else V.singleton "TODO"+ _ -> mempty)+additionalProperties' spec g s (Object val) =+ let sub = compile spec g (RawSchema (_rsURI s) val)+ in Just (\x ->+ case x of+ (Object y) -> (V.fromList . H.elems $ y) >>= validate sub -- TODO: optimize+ _ -> mempty)+additionalProperties' _ _ _ _ = Nothing++additionalProperties :: ValidatorGen+additionalProperties spec g s v = do+ when (H.member "properties" (_rsObject s)) Nothing+ when (H.member "patternProperties" (_rsObject s)) Nothing+ additionalProperties' spec g s v++-- TODO: optimize+--+-- http://json-schema.org/latest/json-schema-validation.html#anchor70+--+-- This keyword's value MUST be an object.+-- Each value of this object MUST be either an object or an array.+--+-- If the value is an object, it MUST be a valid JSON Schema.+-- This is called a schema dependency.+--+-- If the value is an array, it MUST have at least one element.+-- Each element MUST be a string, and elements in the array MUST be unique.+-- This is called a property dependency.+dependencies :: ValidatorGen+dependencies spec g s (Object val) = do+ let vs = V.fromList $ H.toList val+ let schemaDeps = vs >>= toSchemaDep spec g+ let propDeps = vs >>= toPropDep+ when (V.length schemaDeps + V.length propDeps /= V.length vs) Nothing+ Just (\x ->+ case x of+ (Object y) -> join $ (valSD <$> schemaDeps <*> pure y) <> (valPD <$> propDeps <*> pure y)+ _ -> mempty)+ where+ toSchemaDep :: Spec -> Graph -> (Text, Value) -> Vector (Text, Schema)+ toSchemaDep spc gr (t, Object o) = V.singleton (t, compile spc gr $ RawSchema (_rsURI s) o)+ toSchemaDep _ _ _ = mempty++ toPropDep :: (Text, Value) -> Vector (Text, Vector Text)+ toPropDep (t, Array a) =+ if V.length a <= 0+ then mempty+ else case traverse toTxt a of+ Nothing -> mempty+ Just ts ->+ if allUnique ts+ then V.singleton (t, ts)+ else mempty+ toPropDep _ = mempty++ valSD :: (Text, Schema) -> HashMap Text Value -> Vector ValErr+ valSD (t, sub) d =+ case H.lookup t d of+ Nothing -> mempty+ Just _ -> validate sub (Object d)++ valPD :: (Text, Vector Text) -> HashMap Text Value -> Vector ValErr+ valPD (t, ts) d =+ case H.lookup t d of+ Nothing -> mempty+ Just _ ->+ case traverse ($ d) (H.lookup <$> ts) of+ Nothing -> V.singleton "TODO at least one failed"+ Just _ -> mempty++dependencies _ _ _ _ = Nothing++--------------------------------------------------+-- Any Validators+--------------------------------------------------++enum :: ValidatorGen+enum _ _ _ (Array vs) = do+ unless (V.length vs > 0 && allUnique vs) Nothing+ Just (\x ->+ if V.elem x vs+ then mempty+ else V.singleton $ tshow x <> " is not an element of enum " <> tshow vs)+enum _ _ _ _ = Nothing++typeVal :: ValidatorGen+typeVal _ _ _ (String val) = Just (\x -> isJsonType x (V.singleton val))+typeVal _ _ _ (Array vs) = do+ ts <- traverse toTxt vs+ unless (allUnique ts) Nothing+ Just (`isJsonType` ts)+typeVal _ _ _ _ = Nothing++allOf :: ValidatorGen+allOf spec g s (Array vs) = do+ os <- traverse toObj vs+ let ss = compile spec g . RawSchema (_rsURI s) <$> os+ Just (\x -> join $ validate <$> ss <*> pure x)+allOf _ _ _ _ = Nothing++anyOf :: ValidatorGen+anyOf spec g s (Array vs) = do+ os <- traverse toObj vs+ let ss = compile spec g . RawSchema (_rsURI s) <$> os+ Just (\x ->+ if V.elem V.empty (validate <$> ss <*> pure x)+ then mempty+ else V.singleton "TODO")+anyOf _ _ _ _ = Nothing++oneOf :: ValidatorGen+oneOf spec g s (Array vs) = do+ os <- traverse toObj vs+ let ss = compile spec g . RawSchema (_rsURI s) <$> os+ Just (\x ->+ if count V.empty (validate <$> ss <*> pure x) == 1+ then mempty+ else V.singleton "TODO")+oneOf _ _ _ _ = Nothing++notValidator :: ValidatorGen+notValidator spec g s (Object val) = do+ let sub = compile spec g (RawSchema (_rsURI s) val)+ Just (\x ->+ if V.null $ validate sub x+ then V.singleton "TODO"+ else mempty)+notValidator _ _ _ _ = Nothing++-- http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03+--+-- TODO: Any members other than "$ref" in a JSON Reference object SHALL be+-- ignored.+ref :: ValidatorGen+ref spec g s (String val) = do+ (reference, pointer) <- refAndP (_rsURI s `combineIdAndRef` val)+ r <- RawSchema reference <$> H.lookup reference g+ sc <- pointerToSchema pointer r+ Just $ validate (compile spec g sc)+ where+ pointerToSchema :: Text -> RawSchema -> Maybe RawSchema+ pointerToSchema pntr rawS = do+ mVal <- jsonPointer pntr (Object . _rsObject $ rawS)+ case mVal of+ (Object o) -> Just $ RawSchema (_rsURI rawS) o+ _ -> Nothing+ref _ _ _ _ = Nothing
+ tests/Test.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.Aeson.TH+import qualified Data.ByteString.Lazy as LBS+import Data.Char (toLower)+import qualified Data.HashMap.Strict as H+import Data.JsonSchema+import Data.List (isSuffixOf)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector as V+import System.Directory (getDirectoryContents)+import System.FilePath ((</>))+import Test.Framework+import Test.Framework.Providers.HUnit+import qualified Test.HUnit as HU++main :: IO ()+main = do+ ts <- readSchemaTests+ defaultMain (toTest <$> ts)++data SchemaTest = SchemaTest+ { _stDescription :: Text+ , _stSchema :: RawSchema+ , _stCases :: [SchemaTestCase]+ }++data SchemaTestCase = SchemaTestCase+ { _scDescription :: Text+ , _scData :: Value+ , _scValid :: Bool+ }++instance FromJSON RawSchema where+ parseJSON = withObject "Schema" $ \o ->+ return $ RawSchema "" o++instance FromJSON SchemaTest where+ parseJSON = withObject "SchemaTest" $ \o -> SchemaTest+ <$> o .: "description"+ <*> o .: "schema"+ <*> o .: "tests" -- I wish this were "cases"++readSchemaTests :: IO [SchemaTest]+readSchemaTests = do+ jsonFiles <- filter (".json" `isSuffixOf`) <$> getDirectoryContents dir+ fmap concat $ forM jsonFiles $ \file -> do+ let fullPath = dir </> file+ jsonBS <- LBS.readFile fullPath+ case eitherDecode jsonBS of+ Left err -> fail $ "couldn't parse file '" <> fullPath <> "': " <> err+ Right schemas -> return $ prependFileName file <$> schemas+ where+ dir = "JSON-Schema-Test-Suite/tests/draft4"+ prependFileName :: String -> SchemaTest -> SchemaTest+ prependFileName fileName s = s+ { _stDescription = T.pack fileName <> ": " <> _stDescription s+ }++toTest :: SchemaTest -> Test+toTest st = testGroup groupName (mkCase <$> _stCases st)+ where+ groupName :: String+ groupName = T.unpack $ _stDescription st++ mkCase :: SchemaTestCase -> Test+ mkCase sc = testCase caseName assertion+ where+ caseName = T.unpack $ _scDescription sc+ assertion = if _scValid sc+ then assertValid (_stSchema st) (_scData sc)+ else assertInvalid (_stSchema st) (_scData sc)++assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion+assertValid r v = do+ g <- fetchRefs r H.empty+ let es = validate (compile draft4 g r) v+ unless (V.length es == 0) $ HU.assertFailure (show es)+assertInvalid r v = do+ g <- fetchRefs r H.empty+ let es = validate (compile draft4 g r) v+ when (V.length es == 0) $ HU.assertFailure "expected a validation error"++$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)