hjsonschema 0.6.0.2 → 0.7.0.0

raw patch · 18 files changed

+1073/−788 lines, 18 filesdep +containersdep +mtldep +transformersdep ~aesondep ~basedep ~textnew-component:exe:examplePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, mtl, transformers

Dependency ranges changed: aeson, base, text, unordered-containers, vector

API changes (from Hackage documentation)

Files

• Example.hs +74/−0
• README.md +4/−38
• changelog.txt +12/−0
• hjsonschema.cabal +27/−4
• src/Data/JsonSchema.hs +51/−95
• src/Data/JsonSchema/Core.hs +53/−28
• src/Data/JsonSchema/Draft4.hs +140/−0
• src/Data/JsonSchema/Draft4/Any.hs +115/−0
• src/Data/JsonSchema/Draft4/Arrays.hs +91/−0
• src/Data/JsonSchema/Draft4/Numbers.hs +61/−0
• src/Data/JsonSchema/Draft4/Objects.hs +118/−0
• src/Data/JsonSchema/Draft4/Objects/Properties.hs +148/−0
• src/Data/JsonSchema/Draft4/Strings.hs +44/−0
• src/Data/JsonSchema/Helpers.hs +99/−110
• src/Data/JsonSchema/Reference.hs +4/−33
• src/Data/JsonSchema/Validators.hs +0/−468
• src/Import.hs +11/−0
• tests/Lib.hs +21/−12

@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import           Data.Aeson+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 qualified Data.JsonSchema as JS++-- Data.JsonSchema isn't designed to be imported qualified,+-- but we're doing it here to make it obvious what's coming+-- from the lib.++schemaData :: JS.RawSchema+schemaData = JS.RawSchema+  { JS._rsURI    = ""+  , JS._rsObject = schemaJSON+  }+  where+    schemaJSON :: HashMap Text Value+    schemaJSON = H.singleton "uniqueItems" (Bool True)++badData :: Value+badData = Array $ V.fromList ["foo", "foo"]++main :: IO ()+main = do++  let currentSchemaCache = H.empty+  newSchemaCache <- (<> currentSchemaCache) <$> fetchGraph schemaData++  schema <- compileSchema newSchemaCache schemaData+  checkResults (JS.validate schema badData)++  where++    -- Not necessary in this case, but it serves as an example.+    --+    -- Note that Graphs are used to handle internal as well as external references.+    -- So even if a schema doesn't reference outside documents, you still need+    -- to generate a real Graph (and not just use mempty) if it refences itself.+    fetchGraph :: JS.RawSchema -> IO JS.Graph+    fetchGraph rs = do+      eitherGraph <- JS.fetchReferencedSchemas JS.draft4 rs H.empty+      case eitherGraph of+        Left e      -> error $ "Failed to fetch graph with error: " <> T.unpack e+        Right graph -> return graph++    compileSchema :: JS.Graph -> JS.RawSchema -> IO (JS.Schema JS.Draft4Failure)+    compileSchema graph rs =+      case JS.compileDraft4 graph rs of+        Left failure -> error $ "Not a valid schema: " <> show failure+        Right schema -> return schema++    checkResults :: [JS.ValidationFailure JS.Draft4Failure] -> IO ()+    checkResults [] = error "OHNO we validated bad data!"+    checkResults [JS.ValidationFailure JS.UniqueItems (JS.FailureInfo x y)] =+      putStrLn . unlines $+        [ ""+        , "Success. We got a UniqueItems error as expected."+        , "Here's the relevant part of the bad JSON document:"+        , ""+        , "  " <> show y+        , ""+        , "And here's the content of the validator that caught it:"+        , ""+        , "  " <> show x+        ]+    checkResults x = error $ "OHNO we got a different failure than we expected: " <> show x

@@ -6,43 +6,11 @@  Still in development. Lacks solid code to handle changing resolution scope. -# Example--```haskell-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Data.Aeson-import qualified Data.HashMap.Strict as H-import qualified Data.JsonSchema as JS-import qualified Data.Vector as V--main :: IO ()-main = do-  eitherGraph <- JS.fetchRefs JS.draft4 rawSchema H.empty-  case eitherGraph of-    Left e      -> print e-    Right graph ->-      case JS.compileDraft4 graph rawSchema of-        Left e2      -> print e2-        Right schema -> print $ JS.validate schema invalidData--rawSchema :: JS.RawSchema-rawSchema = JS.RawSchema-  { JS._rsURI = ""-  , JS._rsObject = H.singleton "uniqueItems" (Bool True) -- Schema JSON goes here.-  }--invalidData :: Value-invalidData = Array (V.fromList ["foo", "foo"])-```+Also note that hjsonschema uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for the "pattern" validator. This isn't compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires. -Output:-```-Left (fromList ["Val error against uniqueItems True for: Array (fromList [String \"foo\",String \"foo\"])"])-```+# Example +See [Example.hs](./Example.hs).  # Install Tests @@ -50,12 +18,10 @@  # Notes -+ This uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for 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.- + `draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema).  # 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's test code and its implementation of `Graph` both come from Aeson-Schema.+Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema's test code and its implementation of `Graph` both originally came from there.

@@ -1,3 +1,15 @@+# 0.7++Change error type from Text to ValidationFailure.++Revert the 0.6 changes to validate. Also switch from Vector+to list. Validate is now:+  Schema err -> Value -> [ValidationFailure err]++Add fetchReferencedSchemas', which lets the user provide their+own MonadIO function to be used when fetching schemas. This lets+them do things like only fetch schemas from particular domains.+ # 0.6  Break the API so the library doesn't induce boolean blindness.

@@ -1,6 +1,6 @@ name:                   hjsonschema-version:                0.6.0.2-synopsis:               JSON Schema Draft 4 library+version:                0.7.0.0+synopsis:               JSON Schema library homepage:               https://github.com/seagreen/hjsonschema license:                MIT license-file:           MIT-LICENSE.txt@@ -18,27 +18,50 @@ library   hs-source-dirs:       src   exposed-modules:      Data.JsonSchema+                      , Data.JsonSchema.Draft4.Any+                      , Data.JsonSchema.Draft4.Arrays+                      , Data.JsonSchema.Draft4.Numbers+                      , Data.JsonSchema.Draft4.Objects+                      , Data.JsonSchema.Draft4.Strings                       , Data.JsonSchema.Helpers                       , Data.JsonSchema.Reference-                      , Data.JsonSchema.Validators   other-modules:        Data.JsonSchema.Core+                        Data.JsonSchema.Draft4+                      , Data.JsonSchema.Draft4.Objects.Properties+                      , Import   default-language:     Haskell2010-  default-extensions:   OverloadedStrings+  default-extensions:   ScopedTypeVariables+                        OverloadedStrings   other-extensions:     TemplateHaskell   ghc-options:          -Wall   build-depends:        aeson                >= 0.7   && < 0.10                       , base                 >= 4.6   && < 4.9                       , bytestring           >= 0.10  && < 0.11+                      , containers           >= 0.5   && < 0.6                       , file-embed           >= 0.0.8 && < 0.0.10                       , hashable             >= 1.2   && < 1.3                       , hjsonpointer         >= 0.2   && < 0.3                       , http-client          >= 0.4.9 && < 0.5                       , http-types           >= 0.8   && < 0.9+                      , mtl                  >= 2.2.1 && < 2.3                       , regexpr              >= 0.5   && < 0.6                       , scientific           >= 0.3   && < 0.4+                      , transformers         >= 0.4.2 && < 0.5                       , unordered-containers >= 0.2   && < 0.3                       , text                 >= 1.2   && < 1.3                       , vector               >= 0.10  && < 0.12++executable example+  main-is:              Example.hs+  default-language:     Haskell2010+  ghc-options:          -Wall+  build-depends:        aeson+                      , base+                      , hjsonschema+                      , text+                      , unordered-containers+                      , vector+ test-suite local   type:                 exitcode-stdio-1.0   hs-source-dirs:       tests

@@ -1,119 +1,75 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Data.JsonSchema   ( module Data.JsonSchema.Core+    -- * Schema feching tools   , module Data.JsonSchema+    -- * Draft 4 specific+  , module Data.JsonSchema.Draft4   ) where -import           Control.Applicative-import           Data.Aeson-import           Data.ByteString.Lazy       (fromStrict)-import           Data.FileEmbed+import           Control.Monad.Except+import qualified Data.ByteString.Lazy as LBS import           Data.Foldable-import qualified Data.HashMap.Strict        as H+import qualified Data.HashMap.Strict as H+import           Data.String+import qualified Data.Text as T+import qualified Data.Vector as V+ import           Data.JsonSchema.Core-import           Data.JsonSchema.Helpers+import           Data.JsonSchema.Draft4+import qualified Data.JsonSchema.Helpers as HE import           Data.JsonSchema.Reference-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)------------------------------------------------------- * Draft 4 Specific-----------------------------------------------------draft4 :: Spec-draft4 = Spec $ H.fromList-  [ ("$ref"                , (ref                 , noEm))-  , ("multipleOf"          , (multipleOf          , noEm))-  , ("maximum"             , (maximumVal          , noEm))-  , ("minimum"             , (minimumVal          , noEm))-  , ("maxLength"           , (maxLength           , noEm))-  , ("minLength"           , (minLength           , noEm))-  , ("pattern"             , (pattern             , noEm))-  , ("additionalItems"     , (noVal               , objEmbed))-  , ("items"               , (items               , objOrArrayEmbed))-  , ("maxItems"            , (maxItems            , noEm))-  , ("minItems"            , (minItems            , noEm))-  , ("uniqueItems"         , (uniqueItems         , noEm))-  , ("maxProperties"       , (maxProperties       , noEm))-  , ("minProperties"       , (minProperties       , noEm))-  , ("required"            , (required            , noEm))-  , ("properties"          , (properties          , objMembersEmbed))-  , ("patternProperties"   , (patternProperties   , objMembersEmbed))-  , ("additionalProperties", (additionalProperties, objEmbed))-  , ("dependencies"        , (dependencies        , objMembersEmbed))-  , ("enum"                , (enum                , noEm))-  , ("type"                , (typeVal             , noEm))-  , ("allOf"               , (allOf               , arrayEmbed))-  , ("anyOf"               , (anyOf               , arrayEmbed))-  , ("oneOf"               , (oneOf               , arrayEmbed))-  , ("not"                 , (notValidator        , objEmbed))-  , ("definitions"         , (noVal               , objMembersEmbed))-  ]---- | Check if a 'RawSchema' is valid Draft 4 schema.------ This is just a convenience function built by preloading 'validate'--- with the spec schema that describes valid Draft 4 schemas.------ NOTE: It's not actually required to run 'isValidSchema' on--- prospective draft 4 schemas at all. However, it's a good way to--- catch unintentional mistakes in schema documents.-isValidSchema :: RawSchema -> Either (Vector ValErr) Value-isValidSchema r =-  case decode . fromStrict $ $(embedFile "draft4.json") of-    Nothing -> Left $ V.singleton "Schema decode failed (this should never happen)"-    Just s  -> validate (compile draft4 H.empty $ RawSchema "" s) $ Object (_rsObject r)---- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4--- master schema document. Compile it if it does.------ This is just a convenience function built by combining--- 'isValidSchema' and 'compile'.-compileDraft4 :: Graph -> RawSchema -> Either (Vector ValErr) Schema-compileDraft4 g r = isValidSchema r >> return (compile draft4 g r)------------------------------------------------------- * Graph Builder------------------------------------------------------ $ TODO: It would be nice to have a few other functions for building--- out 'Graph's depending on the situation. For instance, there could be--- a function that only fetched "$ref"s which use the "file://" scheme.+import           Import  -- | Take a schema. Retrieve every document either it or its -- subschemas include via the "$ref" keyword. Load a 'Graph' out -- with them. -- -- TODO: This function's URL processing is hacky and needs improvement.-fetchRefs :: Spec -> RawSchema -> Graph -> IO (Either Text Graph)-fetchRefs spec a graph =-  let startingGraph = H.insert (_rsURI a) (_rsObject a) graph-  in foldlM fetch (Right startingGraph) (includeSubschemas a)+fetchReferencedSchemas :: Spec err -> RawSchema -> Graph -> IO (Either Text Graph)+fetchReferencedSchemas = fetchReferencedSchemas' HE.defaultFetch +-- | A version of fetchReferencedSchemas where the function to make requests+-- is provided by the user. This allows restrictions to be added, e.g. rejecting+-- non-local URLs.+fetchReferencedSchemas'+  :: forall t e m err. (IsString t, MonadError t e, Traversable e, MonadIO m)+  => (Text -> m (e LBS.ByteString))+  -> Spec err+  -> RawSchema+  -> Graph+  -> m (e Graph)+fetchReferencedSchemas' fetchRef spec rawSchema graph =+  let startingGraph = H.insert (_rsURI rawSchema) (_rsObject rawSchema) graph+  in foldlM (modFetch fetch) (return startingGraph) (includeSubschemas rawSchema)+   where     includeSubschemas :: RawSchema -> Vector RawSchema     includeSubschemas r =       let newId = newResolutionScope (_rsURI r) (_rsObject r)-          xs = H.intersectionWith (\(_,f) x -> f newId x) (_unSpec spec) (_rsObject r)+          xs = H.intersectionWith (\(ValSpec f _) x -> f newId x) (_unSpec spec) (_rsObject r)           ys = V.concat . H.elems $ xs -- TODO: optimize       in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys -    fetch :: Either Text Graph -> RawSchema -> IO (Either Text Graph)-    fetch (Right g) r =-      case H.lookup "$ref" (_rsObject r) >>= toTxt >>= refAndPointer of-        Nothing     -> return (Right g)+    modFetch :: (Graph -> RawSchema -> m (e Graph)) -> e Graph -> RawSchema -> m (e Graph)+    modFetch f eg rs = join <$> sequence (flip f rs <$> eg)++    fetch :: Graph -> RawSchema -> m (e Graph)+    fetch g r =+      case H.lookup "$ref" (_rsObject r) >>= HE.toTxt >>= refAndPointer of+        Nothing     -> return (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 (Right g)-            else do-              eResp <- fetchRef t-              case eResp of-                Left e    -> return (Left e)-                Right obj -> fetchRefs spec (RawSchema t obj) g-    fetch leftGraph _ = return leftGraph+          let url = (_rsURI r `combineIdAndRef` s)+          in if T.length url <= 0 || H.member url g || not ("://" `T.isInfixOf` url)+            then return (return g)+            else modDec (decodeResponse url) =<< fetchRef url+      where+        decodeResponse :: Text -> LBS.ByteString -> m (e Graph)+        decodeResponse url bts =+          case eitherDecode bts of+            Left e    -> return $ throwError (fromString e)+            Right obj -> fetchReferencedSchemas' fetchRef spec (RawSchema url obj) g++        modDec :: (LBS.ByteString -> m (e Graph)) -> e LBS.ByteString -> m (e Graph)+        modDec f eBts = join <$> sequence (f <$> eBts)

@@ -1,47 +1,51 @@+{-# LANGUAGE ScopedTypeVariables #-}+ module Data.JsonSchema.Core where -import           Data.Aeson-import           Data.HashMap.Strict       (HashMap) import qualified Data.HashMap.Strict       as H-import           Data.JsonSchema.Reference import           Data.Maybe-import           Data.Text                 (Text)-import           Data.Vector               (Vector)-import qualified Data.Vector               as V +import           Data.JsonSchema.Reference+import           Import+ -------------------------------------------------- -- * Primary API -------------------------------------------------- -compile :: Spec -> Graph -> RawSchema -> Schema-compile spec g (RawSchema t o) = Schema . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o+compile :: forall err. Spec err -> Graph -> RawSchema -> Schema err+compile spec g (RawSchema t o) =+  let maybeValidators = H.intersectionWith f (_unSpec spec) o+  in Schema . catMaybes . H.elems $ maybeValidators   where-    f :: (ValidatorGen, a) -> Value -> Maybe Validator-    f (vGen,_) = vGen spec g $ RawSchema (newResolutionScope t o) o+    f :: ValSpec err -> Value -> Maybe (Value -> [ValidationFailure err])+    f (ValSpec _ construct) valJSON = construct spec g (RawSchema (newResolutionScope t o) o) valJSON -validate :: Schema -> Value -> Either (Vector ValErr) Value-validate schema x =-  let errs = V.concatMap ($ x) $ V.fromList (_unSchema schema)-  in if V.null errs-    then Right x-    else Left errs+validate :: Schema err -> Value -> [ValidationFailure err]+validate schema x = concat . fmap ($ x) . _unSchema $ schema  ----------------------------------------------------- * Types+-- * Schemas -------------------------------------------------- -newtype Spec = Spec { _unSpec :: HashMap Text (ValidatorGen, EmbeddedSchemas) }+newtype Spec err = Spec { _unSpec :: HashMap Text (ValSpec err) } --- | Set of potentially mutually recursive schemas.-type Graph = HashMap Text (HashMap Text Value)+newtype Schema err = Schema { _unSchema :: [Value -> [ValidationFailure err]] } -type ValErr = Text+data RawSchema = RawSchema+  { _rsURI    :: Text+  , _rsObject :: HashMap Text Value+  } -newtype Schema = Schema { _unSchema :: [Validator] }+-- | A mapping of URLs to schemas.+--+-- Each key/value pair provides the components of a RawSchema.+type Graph = HashMap Text (HashMap Text Value) -type Validator = Value -> Vector ValErr+--------------------------------------------------+-- * Validators+-------------------------------------------------- -type ValidatorGen = Spec -> Graph -> RawSchema -> Value -> Maybe Validator+data ValSpec err = ValSpec EmbeddedSchemas (ValidatorConstructor err [ValidationFailure err])  -- | Return a schema's immediate subschemas. --@@ -50,7 +54,28 @@ -- "$ref"s and "id"s that are actual schema keywords. type EmbeddedSchemas = Text -> Value -> Vector RawSchema -data RawSchema = RawSchema-  { _rsURI    :: Text-  , _rsObject :: HashMap Text Value-  }+-- | This is what's used to write most validators in practice.+--+-- Its important that particular validators don't know about the error sum type+-- of the Spec they're going to be used in. That way they can be included in+-- other Specs later without encouraging partial functions.+--+-- This means that a properly written ValidatorConstructor will need its error+-- type modified for use in a Spec. Data.JsonSchema.Helpers provides giveName+-- and modifyName for this purpose.+type ValidatorConstructor schemaErr valErr+   = Spec schemaErr+  -> Graph+  -> RawSchema+  -> Value+  -> Maybe (Value -> valErr)++data ValidationFailure err = ValidationFailure+  { _failureName :: err+  , _failureInfo :: FailureInfo+  } deriving (Show, Read)++data FailureInfo = FailureInfo+  { _validatingData :: Value+  , _offendingData  :: Value+  } deriving (Show, Read)

@@ -0,0 +1,140 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.JsonSchema.Draft4 where++import qualified Data.ByteString.Lazy           as LBS+import           Data.FileEmbed+import qualified Data.HashMap.Strict            as H++import           Data.JsonSchema.Core+import           Data.JsonSchema.Draft4.Any+import qualified Data.JsonSchema.Draft4.Arrays as AR+import qualified Data.JsonSchema.Draft4.Numbers as NU+import qualified Data.JsonSchema.Draft4.Objects as OB+import           Data.JsonSchema.Draft4.Strings+import           Data.JsonSchema.Helpers+import           Import++data Draft4Failure+  = MultipleOf++  | Maximum+  | ExclusiveMaximum++  | Minimum+  | ExclusiveMinimum++  | MaxLength+  | MinLength+  | Pattern++  | Items Draft4Failure+  | AdditionalItemsBool+  | AdditionalItemsObject Draft4Failure++  | MaxItems+  | MinItems+  | UniqueItems+  | MaxProperties+  | MinProperties+  | Required++  | Properties Draft4Failure+  | PatternProperties Draft4Failure+  | AdditionalPropertiesBool+  | AdditionalPropertiesObject Draft4Failure++  | SchemaDependency Draft4Failure+  | PropertyDependency++  | Enum+  | TypeValidator+  | AllOf Draft4Failure+  | AnyOf+  | OneOf+  | NotValidator+  | Ref Draft4Failure+  deriving (Eq, Show, Read)++draft4 :: Spec Draft4Failure+draft4 = Spec $ H.fromList+  [ ("$ref"                , ValSpec noEm             (modifyName Ref           ref))+  , ("multipleOf"          , ValSpec noEm             (giveName   MultipleOf    NU.multipleOf))+  , ("maximum"             , ValSpec noEm             (modifyName fMax          NU.maximumVal))+  , ("minimum"             , ValSpec noEm             (modifyName fMin          NU.minimumVal))+  , ("maxLength"           , ValSpec noEm             (giveName   MaxLength     maxLength))+  , ("minLength"           , ValSpec noEm             (giveName   MinLength     minLength))+  , ("pattern"             , ValSpec noEm             (giveName   Pattern       pattern))+  , ("additionalItems"     , ValSpec objEmbed         neverBuild) -- Handled by items.+  , ("items"               , ValSpec objOrArrayEmbed  (modifyName fItems        AR.items))+  , ("maxItems"            , ValSpec noEm             (giveName   MaxItems      AR.maxItems))+  , ("minItems"            , ValSpec noEm             (giveName   MinItems      AR.minItems))+  , ("uniqueItems"         , ValSpec noEm             (giveName   UniqueItems   AR.uniqueItems))+  , ("maxProperties"       , ValSpec noEm             (giveName   MaxProperties OB.maxProperties))+  , ("minProperties"       , ValSpec noEm             (giveName   MinProperties OB.minProperties))+  , ("required"            , ValSpec noEm             (giveName   Required      OB.required))+  , ("properties"          , ValSpec objMembersEmbed  (modifyName fProp         OB.properties))+  , ("patternProperties"   , ValSpec objMembersEmbed  (modifyName fPatProp      OB.patternProperties))+  , ("additionalProperties", ValSpec objEmbed         (modifyName fAddProp      OB.additionalProperties))+  , ("dependencies"        , ValSpec objMembersEmbed  (modifyName fDeps         OB.dependencies))+  , ("enum"                , ValSpec noEm             (giveName   Enum          enum))+  , ("type"                , ValSpec noEm             (giveName   TypeValidator typeValidator))+  , ("allOf"               , ValSpec arrayEmbed       (modifyName AllOf         allOf))+  , ("anyOf"               , ValSpec arrayEmbed       (giveName   AnyOf         anyOf))+  , ("oneOf"               , ValSpec arrayEmbed       (giveName   OneOf         oneOf))+  , ("not"                 , ValSpec objEmbed         (giveName   NotValidator  notValidator))+  , ("definitions"         , ValSpec objMembersEmbed  neverBuild) -- Just contains referenceable schemas.+  ]+  where+    fMax NU.Maximum = Maximum+    fMax NU.ExclusiveMaximum = ExclusiveMaximum++    fMin NU.Minimum = Minimum+    fMin NU.ExclusiveMinimum = ExclusiveMinimum++    fItems (AR.Items err) = Items err+    fItems AR.AdditionalItemsBool = AdditionalItemsBool+    fItems (AR.AdditionalItemsObject err) = AdditionalItemsObject err++    fProp (OB.Properties err) = Properties err+    fProp (OB.PropPattern err) = PatternProperties err+    fProp (OB.PropAdditional OB.AdditionalPropertiesBool) = AdditionalPropertiesBool+    fProp (OB.PropAdditional (OB.AdditionalPropertiesObject err)) = AdditionalPropertiesObject err++    fPatProp (OB.PatternProperties err) = PatternProperties err+    fPatProp (OB.PatternAdditional OB.AdditionalPropertiesBool) = AdditionalPropertiesBool+    fPatProp (OB.PatternAdditional (OB.AdditionalPropertiesObject err)) = AdditionalPropertiesObject err++    fAddProp OB.AdditionalPropertiesBool = AdditionalPropertiesBool+    fAddProp (OB.AdditionalPropertiesObject err) = AdditionalItemsObject err++    fDeps (OB.SchemaDependency err) = SchemaDependency err+    fDeps OB.PropertyDependency = PropertyDependency++-- | Check if a 'RawSchema' is valid Draft 4 schema.+--+-- This is just a convenience function built by preloading 'validate'+-- with the spec schema that describes valid Draft 4 schemas.+--+-- NOTE: It's not actually required to run 'isValidSchema' on+-- prospective draft 4 schemas at all. However, it's a good way to+-- catch unintentional mistakes in schema documents.+isValidSchema :: RawSchema -> [ValidationFailure Draft4Failure]+isValidSchema r =+  case decode . LBS.fromStrict $ $(embedFile "draft4.json") of+    Nothing -> error "Schema decode failed (this should never happen)"+    Just s  -> validate (compile draft4 H.empty $ RawSchema "" s) $ Object (_rsObject r)++-- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4+-- master schema document. Compile it if it does.+--+-- This is just a convenience function built by combining+-- 'isValidSchema' and 'compile'.+--+-- NOTE: It's not actually required to run 'isValidSchema' on+-- prospective draft 4 schemas at all.+compileDraft4 :: Graph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure)+compileDraft4 g r =+  case isValidSchema r of+    []   -> Right (compile draft4 g r)+    errs -> Left errs

@@ -0,0 +1,115 @@++module Data.JsonSchema.Draft4.Any where++import           Control.Monad+import qualified Data.HashMap.Strict       as H+import           Data.JsonPointer+import           Data.Scientific+import           Data.Text.Encoding+import qualified Data.Vector               as V+import           Network.HTTP.Types.URI++import           Data.JsonSchema.Core+import           Data.JsonSchema.Helpers+import           Data.JsonSchema.Reference+import           Import++-- | http://json-schema.org/latest/json-schema-validation.html#anchor76+--+--  > The value of this keyword MUST be an array.+--  > This array MUST have at least one element.+--  > Elements in the array MUST be unique.+--  >+--  > Elements in the array MAY be of any type, including null.+--+-- NOTE: We actually respect this, and don't build the validator+-- if any of the elements aren't unique.+enum :: ValidatorConstructor err [FailureInfo]+enum _ _ _ val@(Array vs) = do+  when (V.null vs || not (allUniqueValues vs)) Nothing+  Just $ \x ->+    if V.elem x vs+      then mempty+      else pure (FailureInfo val x)+enum _ _ _ _ = Nothing++typeValidator :: ValidatorConstructor err [FailureInfo]+typeValidator _ _ _ (String val) = Just $ \x -> isJsonType x (pure val)+typeValidator _ _ _ (Array vs) = do+  ts <- traverse toTxt vs+  unless (allUnique ts) Nothing+  Just (`isJsonType` ts)+typeValidator _ _ _ _ = Nothing++isJsonType :: Value -> Vector Text -> [FailureInfo]+isJsonType x xs =+  case x of+    (Null)     -> f "null"    xs+    (Array _)  -> f "array"   xs+    (Bool _)   -> f "boolean" xs+    (Object _) -> f "object"  xs+    (String _) -> f "string"  xs+    (Number y) ->+      case toBoundedInteger y :: Maybe Int of+        Nothing -> f "number" xs+        Just _  -> if V.elem "integer" xs+                     then mempty+                     else f "number" xs+  where+    f :: Text -> Vector Text -> [FailureInfo]+    f t ts = if V.elem t ts+               then mempty+               else pure $ FailureInfo (Array (String <$> xs)) x++allOf :: ValidatorConstructor err [ValidationFailure err]+allOf spec g s (Array vs) = do+  os <- traverse toObj vs+  let subSchemas = compile spec g . RawSchema (_rsURI s) <$> V.toList os+  Just $ \x -> join $ flip validate x <$> subSchemas+allOf _ _ _ _ = Nothing++anyOf :: ValidatorConstructor err [FailureInfo]+anyOf spec g s val@(Array vs) = do+  os <- traverse toObj vs+  let subSchemas = compile spec g . RawSchema (_rsURI s) <$> os+  Just $ \x ->+    if any null (flip validate x <$> subSchemas)+      then mempty+      else pure (FailureInfo val x)+anyOf _ _ _ _ = Nothing++oneOf :: ValidatorConstructor err [FailureInfo]+oneOf spec g s val@(Array vs) = do+  os <- traverse toObj $ V.toList vs+  let subSchemas = compile spec g . RawSchema (_rsURI s) <$> os+  Just $ \x ->+    if (length . filter null $ flip validate x <$> subSchemas) == 1+      then mempty+      else pure (FailureInfo val x)+oneOf _ _ _ _ = Nothing++notValidator :: ValidatorConstructor err [FailureInfo]+notValidator spec g s val@(Object o) = do+  let sub = compile spec g (RawSchema (_rsURI s) o)+  Just $ \x ->+    case validate sub x of+      [] -> pure (FailureInfo val x)+      _  -> 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 :: ValidatorConstructor err [ValidationFailure err]+ref spec g s (String val) = do+  (reference, pointer) <- refAndPointer (_rsURI s `combineIdAndRef` val)+  r <- RawSchema reference <$> H.lookup reference g+  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer+  p <- eitherToMaybe $ jsonPointer urlDecoded+  case resolvePointer p (Object $ _rsObject r) of+    Right (Object o) ->+      let compiled = compile spec g $ RawSchema (_rsURI r) o+      in Just $ validate compiled+    _ -> Nothing+ref _ _ _ _ = Nothing

@@ -0,0 +1,91 @@++module Data.JsonSchema.Draft4.Arrays where++import           Control.Monad+import qualified Data.HashMap.Strict     as H+import qualified Data.Vector             as V++import           Data.JsonSchema.Core+import           Data.JsonSchema.Helpers+import           Import++data ItemsFailure err = Items err | AdditionalItemsBool | AdditionalItemsObject err++-- | A combination of items and additionalItems.+items :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]+items spec g s (Object o) =+  let subSchema = compile spec g (RawSchema (_rsURI s) o)+  in Just $ \x ->+    case x of+      Array ys -> V.toList ys >>= fmap (modifyFailureName Items) . validate subSchema+      _        -> mempty+items spec g s (Array vs) = do+  os <- traverse toObj vs+  let subSchemas = compile spec g . RawSchema (_rsURI s) <$> V.toList os+      mAdditionalItems = additionalItems spec g s =<< H.lookup "additionalItems" (_rsObject s)+  Just $ \x ->+    case x of+      Array ys ->+        let extras = V.drop (V.length os) ys+            itemFailures = join $ fmap (modifyFailureName Items) <$> zipWith validate subSchemas (V.toList ys)+            additionalItemFailures = runMaybeVal mAdditionalItems (Array extras)+        in itemFailures <> additionalItemFailures+      _ -> mempty+items _ _ _ _ = Nothing++-- | Not included directly in the 'draft4' spec hashmap because it always+-- validates data unless 'items' is also present. This is because 'items'+-- defaults to {}.+--+-- TODO: Should have its own error type instead of sharing with Items.+additionalItems :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]+additionalItems _ _ _ val@(Bool v) =+  Just $ \x ->+    case x of+      Array ys ->+        if not v && V.length ys > 0+          then pure $ ValidationFailure AdditionalItemsBool (FailureInfo val x)+          else mempty+      _ -> mempty+additionalItems spec g s (Object o) =+  let subSchema = compile spec g (RawSchema (_rsURI s) o)+  in Just $ \x ->+    case x of+      Array ys -> V.toList ys >>= fmap (modifyFailureName AdditionalItemsObject) . validate subSchema+      _        -> mempty+additionalItems _ _ _ _ = Nothing++maxItems :: ValidatorConstructor err [FailureInfo]+maxItems _ _ _ val = do+  n <- fromJSONInt val+  greaterThanZero n+  Just $ \x ->+    case x of+      Array ys ->+        if V.length ys > n+          then pure (FailureInfo val x)+          else mempty+      _ -> mempty++minItems :: ValidatorConstructor err [FailureInfo]+minItems _ _ _ val = do+  n <- fromJSONInt val+  greaterThanZero n+  Just $ \x ->+    case x of+      Array ys ->+        if V.length ys < n+          then pure (FailureInfo val x)+          else mempty+      _ -> mempty++uniqueItems :: ValidatorConstructor err [FailureInfo]+uniqueItems _ _ _ val@(Bool v) = do+  unless v Nothing+  Just $ \x ->+    case x of+      (Array ys) -> if allUniqueValues ys+        then mempty+        else pure (FailureInfo val x)+      _ -> mempty+uniqueItems _ _ _ _ = Nothing

@@ -0,0 +1,61 @@++module Data.JsonSchema.Draft4.Numbers where++import           Data.Fixed              (mod')+import qualified Data.HashMap.Strict     as H+import           Data.Scientific++import           Data.JsonSchema.Core+import           Data.JsonSchema.Helpers+import           Import++data MaximumFailure = Maximum | ExclusiveMaximum+data MinimumFailure = Minimum | ExclusiveMinimum++multipleOf :: ValidatorConstructor err [FailureInfo]+multipleOf _ _ _ val@(Number n) = do+  greaterThanZero n+  Just $ \x ->+    case x of+      Number y ->+        if y `mod'` n /= 0+          then pure (FailureInfo val x)+          else mempty+      _ -> mempty+multipleOf _ _ _ _ = Nothing++maximumVal :: ValidatorConstructor err [ValidationFailure MaximumFailure]+maximumVal _ _ s val@(Number n) =+  Just $ \x ->+    case x of+      Number y ->+        let (greater, err) = checkExclusive+        in if y `greater` n+          then pure $ ValidationFailure err (FailureInfo val x)+          else mempty+      _ -> mempty+  where+    checkExclusive :: (Scientific -> Scientific -> Bool, MaximumFailure)+    checkExclusive =+      case H.lookup "exclusiveMaximum" (_rsObject s) of+        Just (Bool a) -> if a then ((>=), ExclusiveMaximum) else ((>), Maximum)+        _             -> ((>), Maximum)+maximumVal _ _ _ _ = Nothing++minimumVal :: ValidatorConstructor err [ValidationFailure MinimumFailure]+minimumVal _ _ s val@(Number n) =+  Just $ \x ->+    case x of+      Number y ->+        let (lesser, err) = checkExclusive+        in if y `lesser` n+          then pure $ ValidationFailure err (FailureInfo val x)+          else mempty+      _ -> mempty+  where+    checkExclusive :: (Scientific -> Scientific -> Bool, MinimumFailure)+    checkExclusive =+      case H.lookup "exclusiveMinimum" (_rsObject s) of+        Just (Bool a) -> if a then ((<=), ExclusiveMinimum) else ((<), Minimum)+        _             -> ((<), Minimum)+minimumVal _ _ _ _ = Nothing

@@ -0,0 +1,118 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.JsonSchema.Draft4.Objects+  ( module Data.JsonSchema.Draft4.Objects+  , module Data.JsonSchema.Draft4.Objects.Properties+  ) where++import           Control.Monad+import           Data.Aeson+import           Data.Hashable+import qualified Data.HashMap.Strict     as H+import qualified Data.Vector             as V++import           Data.JsonSchema.Core+import           Data.JsonSchema.Draft4.Objects.Properties+import           Data.JsonSchema.Helpers+import           Import++data DependencyFailure err = SchemaDependency err | PropertyDependency++maxProperties :: ValidatorConstructor err [FailureInfo]+maxProperties _ _ _ val = do+  n <- fromJSONInt val+  greaterThanZero n+  Just $ \x ->+    case x of+      Object o ->+        if H.size o > n+          then pure (FailureInfo val x)+          else mempty+      _ -> mempty++minProperties :: ValidatorConstructor err [FailureInfo]+minProperties _ _ _ val = do+  n <- fromJSONInt val+  greaterThanZero n+  Just $ \x ->+    case x of+      Object o ->+        if H.size o < n+          then pure (FailureInfo val x)+          else mempty+      _ -> mempty++required :: ValidatorConstructor err [FailureInfo]+required _ _ _ val@(Array vs) = do+  when (V.length vs == 0) Nothing+  ts <- traverse toTxt vs+  let a = vectorToMapSet 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 pure (FailureInfo val x)+          else mempty+      _ -> mempty+  where+    vectorToMapSet :: (Eq a, Hashable a) => Vector a -> HashMap a Bool+    vectorToMapSet vec = H.fromList . V.toList $ (\x -> (x, True)) <$> vec -- TODO: use a fold.+required _ _ _ _ = Nothing++-- 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 :: ValidatorConstructor err [ValidationFailure (DependencyFailure err)]+dependencies spec g s val@(Object o) = do+  let vs = H.toList o+      schemaDeps = vs >>= toSchemaDep spec g+      propDeps = vs >>= toPropDep+  when (length schemaDeps + length propDeps /= length vs) Nothing+  Just $ \x ->+    case x of+      Object y ->+        let schemaFailures = join $ valSD y <$> schemaDeps+            propertyFailures = join $ valPD y <$> propDeps+        in schemaFailures <> propertyFailures+      _ -> mempty+  where+    toSchemaDep :: Spec a -> Graph -> (Text, Value) -> [(Text, Schema a)]+    toSchemaDep spc gr (t, Object ob) = pure (t, compile spc gr $ RawSchema (_rsURI s) ob)+    toSchemaDep _ _ _ = mempty++    toPropDep :: (Text, Value) -> [(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 pure (t, ts)+              else mempty+    toPropDep _ = mempty++    valSD :: HashMap Text Value -> (Text, Schema err) -> [ValidationFailure (DependencyFailure err)]+    valSD d (k, subSchema) =+      case H.lookup k d of+        Nothing -> mempty+        Just _  -> modifyFailureName SchemaDependency <$> validate subSchema (Object d)++    valPD :: HashMap Text Value -> (Text, Vector Text) -> [ValidationFailure (DependencyFailure err)]+    valPD d (k, ks) =+      case H.lookup k d of+        Nothing -> mempty+        Just _  ->+          case traverse (flip H.lookup d) ks of+            Nothing -> pure $ ValidationFailure PropertyDependency (FailureInfo val (Object d))+            Just _  -> mempty+dependencies _ _ _ _ = Nothing

@@ -0,0 +1,148 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.JsonSchema.Draft4.Objects.Properties where++import           Control.Monad+import           Data.Aeson+import qualified Data.HashMap.Strict     as H+import           Data.Maybe+import qualified Data.Text               as T+import           Text.RegexPR++import           Data.JsonSchema.Core+import           Data.JsonSchema.Helpers+import           Import++data PropertiesFailure err+  = Properties err+  | PropPattern err+  | PropAdditional (AdditionalPropertiesFailure err)++data PatternPropertiesFailure err+  = PatternProperties err+  | PatternAdditional (AdditionalPropertiesFailure err)++data AdditionalPropertiesFailure err+  = AdditionalPropertiesBool+  | AdditionalPropertiesObject err++-- | In order of what's tried: properties, patternProperties, additionalProperties+properties :: forall err. ValidatorConstructor err [ValidationFailure (PropertiesFailure err)]+properties spec g s val = do+  let mProps   = propertiesUnmatched val+      mPatProp = patternUnmatched spec g s =<< H.lookup "patternProperties" (_rsObject s)+      mAddProp = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)+  when (isNothing mProps && isNothing mPatProp && isNothing mAddProp) Nothing+  Just $ \x ->+    case x of+      Object y ->+        let (propFailures, remaining) = runMaybeVal' mProps (Object y)+            patternFailures           = fst $ runMaybeVal' mPatProp (Object y)+            remaining'                = snd $ runMaybeVal' mPatProp remaining+            additionalFailures        = runMaybeVal mAddProp remaining'+        in fmap (modifyFailureName Properties) propFailures+             <> fmap (modifyFailureName PropPattern) patternFailures+             <> fmap (modifyFailureName PropAdditional) additionalFailures+      _ -> mempty+  where+    propertiesUnmatched :: Value -> Maybe (Value -> ([ValidationFailure err], Value))+    propertiesUnmatched (Object o) = do+      os <- traverse toObj o+      let matchedSchemas = compile spec g . RawSchema (_rsURI s) <$> os+      Just (\x ->+        case x of+          Object y ->+            let rawFailures = H.intersectionWith validate matchedSchemas y+                failures = join (H.elems rawFailures)+                leftovers = Object (H.difference y matchedSchemas)+            in (failures, leftovers)+          z -> (mempty, z))+    propertiesUnmatched _ = Nothing++patternProperties :: ValidatorConstructor err [ValidationFailure (PatternPropertiesFailure err)]+patternProperties spec g s val = do+  when (H.member "properties" (_rsObject s)) Nothing+  let mPatternProps = patternUnmatched spec g s val+  -- TODO: checking additionalProperties as well doesn't help with tests.+  -- Make sure we're doing the correct thing, then get tests for this+  -- merged into the test suite.+  let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)+  when (isNothing mPatternProps && isNothing mAdditionalProps) Nothing+  Just $ \x ->+    case x of+      Object y ->+        let (ppFailures, remaining') = runMaybeVal' mPatternProps (Object y)+            addFailures              = runMaybeVal mAdditionalProps remaining'+        in fmap (modifyFailureName PatternProperties) ppFailures <> fmap (modifyFailureName PatternAdditional) addFailures+      _ -> mempty++patternUnmatched+  :: Spec err+  -> Graph+  -> RawSchema+  -> Value+  -> Maybe (Value -> ([ValidationFailure err], Value))+patternUnmatched spec g s (Object val) = do+  os <- traverse toObj val+  let subSchemas = compile spec g . RawSchema (_rsURI s) <$> os+  Just (\x ->+    case x of+      Object y -> let ms = H.foldlWithKey' (matches subSchemas) mempty y+                  in (H.foldl' runVals mempty ms, Object (leftovers ms))+      _        -> (mempty, x))+  where+    matches+      :: HashMap Text (Schema a)+      -> HashMap Text (Value, [Schema a])+      -> Text+      -> Value+      -> HashMap Text (Value, [Schema a])+    matches subSchemas acc k v = H.insert k (v, H.foldlWithKey' (match k) mempty subSchemas) acc++    match+      :: Text+      -> [Schema a]+      -> Text+      -> Schema a+      -> [Schema a]+    match k acc r subSchema =+      case matchRegexPR (T.unpack r) (T.unpack k) of+        Nothing -> acc+        Just _  -> pure subSchema <> acc++    runVals+      :: [ValidationFailure err]+      -> (Value, [Schema err])+      -> [ValidationFailure err]+    runVals acc (v,subSchema) = (subSchema >>= flip validate v) <> acc++    leftovers :: HashMap Text (Value, [Schema a]) -> HashMap Text Value+    leftovers possiblyMatched = fst <$> H.filter (null . snd) possiblyMatched+patternUnmatched _ _ _ _ = Nothing++additionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)]+additionalProperties spec g s val = do+  when (H.member "properties" (_rsObject s)) Nothing+  when (H.member "patternProperties" (_rsObject s)) Nothing+  runAdditionalProperties spec g s val++-- | An additionalProperties validator than never disables itself.+--+-- Not meant to be used standalone, but useful inside of the properties+-- and patternProperties validators.+runAdditionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)]+runAdditionalProperties _ _ _ val@(Bool v) =+  Just $ \x ->+    case x of+      Object y ->+        if not v && H.size y > 0+          then pure $ ValidationFailure AdditionalPropertiesBool (FailureInfo val x)+          else mempty+      _ -> mempty+runAdditionalProperties spec g s (Object o) =+  let sub = compile spec g (RawSchema (_rsURI s) o)+  in Just $ \x ->+    case x of+      Object y -> H.elems y >>= fmap (modifyFailureName AdditionalPropertiesObject) . validate sub+      _        -> mempty+runAdditionalProperties _ _ _ _ = Nothing

@@ -0,0 +1,44 @@++module Data.JsonSchema.Draft4.Strings where++import qualified Data.Text               as T+import           Text.RegexPR++import           Data.JsonSchema.Core+import           Data.JsonSchema.Helpers+import           Import++maxLength :: ValidatorConstructor err [FailureInfo]+maxLength _ _ _ val = do+  n <- fromJSONInt val+  greaterThanZero n+  Just $ \x ->+    case x of+      String y ->+        if T.length y > n+          then pure (FailureInfo val x)+          else mempty+      _ -> mempty++minLength :: ValidatorConstructor err [FailureInfo]+minLength _ _ _ val = do+  n <- fromJSONInt val+  greaterThanZero n+  Just $ \x ->+    case x of+      String y ->+        if T.length y < n+          then pure (FailureInfo val x)+          else mempty+      _ -> mempty++pattern :: ValidatorConstructor err [FailureInfo]+pattern _ _ _ val@(String t) =+  Just $ \x ->+    case x of+      String y ->+        case matchRegexPR (T.unpack t) (T.unpack y) of+          Nothing -> pure (FailureInfo val x)+          Just _  -> mempty+      _ -> mempty+pattern _ _ _ _ = Nothing

@@ -1,156 +1,111 @@ module Data.JsonSchema.Helpers where -import           Control.Applicative-import           Control.Monad-import           Data.Aeson-import           Data.Hashable-import           Data.HashMap.Strict  (HashMap)+import           Control.Exception+import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict  as H-import           Data.JsonSchema.Core-import           Data.List-import           Data.Monoid import           Data.Scientific-import           Data.Text            (Text)+import qualified Data.Set as S import qualified Data.Text            as T-import           Data.Traversable-import           Data.Vector          (Vector) import qualified Data.Vector          as V-import           Text.RegexPR+import           Network.HTTP.Client +import           Data.JsonSchema.Core+import           Import+ ----------------------------------------------------- * Embedded Schema Layouts+-- * Embedded schemas finders --------------------------------------------------  noEm :: EmbeddedSchemas-noEm _ _ = V.empty+noEm _ _ = mempty  objEmbed :: EmbeddedSchemas-objEmbed t (Object o) = V.singleton $ RawSchema t o-objEmbed _ _ = V.empty+objEmbed t (Object o) = pure (RawSchema t o)+objEmbed _ _ = mempty --- TODO: optimize arrayEmbed :: EmbeddedSchemas-arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs-arrayEmbed _ _ = V.empty+arrayEmbed t (Array vs) = objEmbed t =<< vs+arrayEmbed _ _ = mempty  objOrArrayEmbed :: EmbeddedSchemas objOrArrayEmbed t v@(Object _) = objEmbed t v objOrArrayEmbed t v@(Array _) = arrayEmbed t v-objOrArrayEmbed _ _ = V.empty+objOrArrayEmbed _ _ = mempty  objMembersEmbed :: EmbeddedSchemas-objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o-objMembersEmbed _ _ = V.empty+objMembersEmbed t (Object o) = objEmbed t =<< V.fromList (H.elems o)+objMembersEmbed _ _ = mempty  ----------------------------------------------------- * Validator Helpers+-- * Modify Validators for use in Specs -------------------------------------------------- -patternPropertiesMatches-  :: Spec-  -> Graph-  -> RawSchema-  -> Value-  -> Maybe (Value -> (Vector ValErr, Value))-patternPropertiesMatches 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 (hmToVector vs) <$> hmToVector 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 . vLefts $ 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 . vectorToHm $ (\(v,k,_) -> (v,k)) <$> unmatched-patternPropertiesMatches _ _ _ _ = Nothing+-- | TODO: Is there something easier to replace these fmaps with?+giveName+  :: forall err. err+  -> ValidatorConstructor err [FailureInfo]+  -> ValidatorConstructor err [ValidationFailure err]+giveName err = (fmap.fmap.fmap.fmap.fmap.fmap.fmap) (ValidationFailure err) -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+modifyName+  :: forall valErr schemaErr. (valErr -> schemaErr)+  -> ValidatorConstructor schemaErr [ValidationFailure valErr]+  -> ValidatorConstructor schemaErr [ValidationFailure schemaErr]+modifyName failureHandler = (fmap.fmap.fmap.fmap.fmap.fmap.fmap) f   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+    f :: ValidationFailure valErr -> ValidationFailure schemaErr+    f (ValidationFailure a b) = ValidationFailure (failureHandler a) b -    mkErr :: (Show a) => a -> Vector Text -> Vector ValErr-    mkErr y ts = V.singleton (tshow y <> " is not one of the types " <> tshow ts)+-- | It's important to know if an object's a validator (even if it will never run,+-- like the definitions validator) because parts of it might be referenced by other+-- validators. If one of those referenced parts is itself a valid reference we+-- need to have fetched the correct value for it. So validators that won't run are+-- different than non-validator objects, because even if a non-validator object has+-- a $ref" keyword it's not a valid reference and shouldn't be fetched.+neverBuild :: ValidatorConstructor err [ValidationFailure err]+neverBuild _ _ _ _ = Nothing  -------------------------------------------------- -- * Utils -------------------------------------------------- -vLefts :: Vector (Either a b) -> Vector a-vLefts = V.concatMap f-  where-    f :: Either a b -> Vector a-    f (Left e)  = V.singleton e-    f (Right _) = mempty+-- | Export the fetch function used by fetchReferencedSchemas+defaultFetch :: Text -> IO (Either Text LBS.ByteString)+defaultFetch url = do+  eResp <- catch (Right <$> simpleHttp') handler+  case eResp of+    Left e  -> return $ Left e+    Right b -> return $ Right b -vRights :: Vector (Either a b) -> Vector b-vRights = V.concatMap f-  where-    f :: Either a b -> Vector b-    f (Left _)  = mempty-    f (Right a) = V.singleton a+    where+      handler :: SomeException -> IO (Either Text LBS.ByteString)+      handler e = return . Left . T.pack . show $ e +      -- Modeled on Network.Http.Conduit.simpleHttp from http-conduit.+      -- simpleHttp also sets "Connection: close"+      simpleHttp' :: IO LBS.ByteString+      simpleHttp' = do+        man <- newManager defaultManagerSettings+        req <- parseUrl (T.unpack url)+        responseBody <$> httpLbs req { requestHeaders = ("Connection", "close") : requestHeaders req } man++modifyFailureName :: (a -> b) -> ValidationFailure a -> ValidationFailure b+modifyFailureName f (ValidationFailure a b) = ValidationFailure (f a) b+ eitherToMaybe :: Either a b -> Maybe b eitherToMaybe (Left _)  = Nothing eitherToMaybe (Right a) = Just a -vectorOfElems :: HashMap k a -> Vector a-vectorOfElems = V.fromList . H.elems--hmToVector :: HashMap k a -> Vector (k, a)-hmToVector = V.fromList . H.toList--vectorToHm :: (Eq k, Hashable k) => Vector (k, a) -> HashMap k a-vectorToHm = H.fromList . V.toList--runMaybeVal :: Maybe Validator -> Value -> Vector ValErr+runMaybeVal :: Maybe (Value -> [a]) -> Value -> [a] runMaybeVal Nothing _ = mempty-runMaybeVal (Just val) d = val d+runMaybeVal (Just val) x = val x  runMaybeVal'-  :: Maybe (Value -> (Vector ValErr, Value))+  :: Maybe (Value -> ([a], 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+  -> ([a], Value)+runMaybeVal' Nothing x = (mempty, x)+runMaybeVal' (Just val) x = val x  toObj :: Value -> Maybe (HashMap Text Value) toObj (Object a) = Just a@@ -169,3 +124,37 @@  tshow :: Show a => a -> Text tshow = T.pack . show++allUnique :: (Ord a) => Vector a -> Bool+allUnique xs = S.size (S.fromList (V.toList xs)) == V.length xs++-- | This needs benchmarking, but it can't be as bad as using O(n^2) nub.+-- (We can't use our allUnique function directly on Values because they're+-- not an instance of Ord).+allUniqueValues :: Vector Value -> Bool+allUniqueValues = allUnique . fmap OrdValue++newtype OrdValue = OrdValue Value deriving Eq++instance Ord OrdValue where+  (OrdValue Null) `compare` (OrdValue Null) = EQ+  (OrdValue Null) `compare` _               = LT+  _               `compare` (OrdValue Null) = GT++  (OrdValue (Bool x)) `compare` (OrdValue (Bool y)) = x `compare` y+  (OrdValue (Bool _)) `compare` _                   = LT+  _                   `compare` (OrdValue (Bool _)) = GT++  (OrdValue (Number x)) `compare` (OrdValue (Number y)) = x `compare` y+  (OrdValue (Number _)) `compare` _                     = LT+  _                     `compare` (OrdValue (Number _)) = GT++  (OrdValue (String x)) `compare` (OrdValue (String y)) = x `compare` y+  (OrdValue (String _)) `compare` _                     = LT+  _                     `compare` (OrdValue (String _)) = GT++  (OrdValue (Array xs)) `compare` (OrdValue (Array ys)) = (OrdValue <$> xs) `compare` (OrdValue <$> ys)+  (OrdValue (Array _))  `compare` _                     = LT+  _                     `compare` (OrdValue (Array _))  = GT++  (OrdValue (Object x)) `compare` (OrdValue (Object y)) = H.toList (OrdValue <$> x) `compare` H.toList (OrdValue <$> y)

@@ -3,20 +3,11 @@  module Data.JsonSchema.Reference where -import           Control.Applicative-import           Control.Arrow-import           Control.Exception-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           Network.HTTP.Client-import           Prelude              hiding (foldr)+import qualified Data.HashMap.Strict as H+import qualified Data.Text           as T +import           Import+ combineIdAndRef :: Text -> Text -> Text combineIdAndRef a b   | "://" `T.isInfixOf` b              = b@@ -46,23 +37,3 @@     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 e  -> return $ Left e-    Right b -> return . left T.pack $ eitherDecode b--safeGet :: Text -> IO (Either Text ByteString)-safeGet url = catch (Right <$> simpleHttp') handler-  where-    handler :: SomeException -> IO (Either Text ByteString)-    handler e = return . Left . T.pack . show $ e--    -- We don't want to depend on http-conduit, but Network.Http.Conduit.simpleHttp-    -- is the model for this function. simpleHttp also sets "Connection: close".-    simpleHttp' :: IO ByteString-    simpleHttp' = fmap responseBody $ withManager defaultManagerSettings $ \man -> do-      req <- parseUrl (T.unpack url)-      httpLbs req { requestHeaders = ("Connection", "close") : requestHeaders req } man

@@ -1,468 +0,0 @@--- | 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.--module Data.JsonSchema.Validators where--import           Control.Applicative-import           Control.Monad-import           Data.Aeson-import           Data.Either-import           Data.Fixed                (mod')-import           Data.Hashable-import           Data.HashMap.Strict       (HashMap)-import qualified Data.HashMap.Strict       as H-import           Data.JsonPointer-import           Data.JsonSchema.Core-import           Data.JsonSchema.Helpers-import           Data.JsonSchema.Reference-import           Data.Maybe-import           Data.Monoid-import           Data.Scientific-import           Data.Text                 (Text)-import qualified Data.Text                 as T-import           Data.Text.Encoding-import           Data.Traversable-import           Data.Vector               (Vector)-import qualified Data.Vector               as V-import           Network.HTTP.Types.URI-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) =-  Just (\x ->-    case x of-      Number y ->-        if y `greater` val-          then V.singleton (tshow y <> " fails to validate against maximum " <> tshow val)-          else mempty-      _ -> mempty)-  where-    greater :: Scientific -> Scientific -> Bool-    greater =-      case H.lookup "exclusiveMaximum" (_rsObject s) of-        Just (Bool a) -> if a then (>=) else (>)-        _             -> (>)-maximumVal _ _ _ _ = Nothing--minimumVal :: ValidatorGen-minimumVal _ _ s (Number val) =-  Just (\x ->-    case x of-      Number y ->-        if y `lesser` val-          then V.singleton (tshow y <> " fails to validate against minimum " <> tshow val)-          else mempty-      _ -> mempty)-  where-    lesser :: Scientific -> Scientific -> Bool-    lesser =-      case H.lookup "exclusiveMinimum" (_rsObject s) of-        Just (Bool a) -> if a then (<=) else (<)-        _             -> (<)-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.-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 >>= either id mempty . 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 (either id mempty <$> V.zipWith validate ss ys)-           <> runMaybeVal addItems (Array extras)-      _ -> mempty)-items _ _ _ _ = Nothing---- | Not included directly in the 'draft4' spec hashmap because it always--- validates data unless 'items' is also present. This is because 'items'--- defaults to {}.-additionalItems :: ValidatorGen-additionalItems _ _ _ (Bool val) =-  Just (\x ->-    case x of-      Array ys ->-        if not val && V.length ys > 0-          then V.singleton ("Val error against additionalItems false for: " <> tshow x)-          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 >>= either id mempty . 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 ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)-      _ -> 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 = vectorToMapSet 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-    vectorToMapSet :: (Eq a, Hashable a) => Vector a -> HashMap a Bool-    vectorToMapSet vec = vectorToHm $ (\x -> (x, True)) <$> vec-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 = propertiesMatches v-  let mPatProp = do-                  aV <- H.lookup "patternProperties" (_rsObject s)-                  patternPropertiesMatches spec g s aV-  let mAdd = do-              aVal <- H.lookup "additionalProperties" (_rsObject s)-              runAdditionalProperties 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)-  where-    propertiesMatches :: Value -> Maybe (Value -> (Vector ValErr, Value))-    propertiesMatches (Object val) = do-      os <- traverse toObj val-      let oss = compile spec g . RawSchema (_rsURI s) <$> os-      Just (\x ->-        case x of-          Object y -> ( join . vectorOfElems $ either id mempty <$> H.intersectionWith validate oss y-                      , Object $ H.difference y oss)-          z        -> (mempty, z))-    propertiesMatches _ = Nothing--patternProperties :: ValidatorGen-patternProperties spec g s v = do-  when (H.member "properties" (_rsObject s)) Nothing-  let mPatProp = patternPropertiesMatches spec g s v-  -- TODO: checking additionalProperties as well doesn't help with tests-  let mAdd = do-              aVal <- H.lookup "additionalProperties" (_rsObject s)-              runAdditionalProperties 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)---- | An implementation of the "additionalProperties" keyword that never--- disables itself. Not included directly in the 'draft4' spec hashmap.-runAdditionalProperties :: ValidatorGen-runAdditionalProperties _ _ _ (Bool val) =-  Just (\x ->-    case x of-      Object y ->-        if not val && H.size y > 0-          then V.singleton ("Val error against additionalProperties false for: " <> tshow x)-          else mempty-      _ -> mempty)-runAdditionalProperties spec g s (Object val) =-  let sub = compile spec g (RawSchema (_rsURI s) val)-  in Just (\x ->-    case x of-      Object y -> vectorOfElems y >>= either id mempty . validate sub-      _        -> mempty)-runAdditionalProperties _ _ _ _ = Nothing--additionalProperties :: ValidatorGen-additionalProperties spec g s v = do-  when (H.member "properties" (_rsObject s)) Nothing-  when (H.member "patternProperties" (_rsObject s)) Nothing-  runAdditionalProperties spec g s v---- 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 = hmToVector val-      schemaDeps = vs >>= toSchemaDep spec g-      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 _  -> either id (const mempty) $ 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 ("Val error against property dependency with key: " <> t-                                    <> " and value " <> tshow ts <> " for: " <> tshow d)-            Just _  -> mempty--dependencies _ _ _ _ = Nothing------------------------------------------------------- * Any Validators------------------------------------------------------- | http://json-schema.org/latest/json-schema-validation.html#anchor76------  > The value of this keyword MUST be an array.---  > This array MUST have at least one element.---  > Elements in the array MUST be unique.---  >---  > Elements in the array MAY be of any type, including null.------ NOTE: We actually respect this, and don't build the validator--- if any of the elements aren't unique.-enum :: ValidatorGen-enum _ _ _ (Array vs) = do-  when (V.null vs || not (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 . vLefts $ 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 ->-    case listToMaybe . rights $ validate <$> V.toList ss <*> pure x of-      Nothing -> V.singleton ("Val error against anyOf " <> tshow vs <> " for: " <> tshow x)-      Just _  -> mempty )-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 V.length (vRights $ validate <$> ss <*> pure x) == 1-      then mempty-      else V.singleton ("Val error against oneOf " <> tshow vs <> " for: " <> tshow x))-oneOf _ _ _ _ = Nothing--notValidator :: ValidatorGen-notValidator spec g s (Object val) = do-  let sub = compile spec g (RawSchema (_rsURI s) val)-  Just (\x ->-    case validate sub x of-      Left _  -> mempty-      Right _ -> V.singleton ("Val error against not validator " <> tshow val-                              <> " for: " <> tshow x))-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) <- refAndPointer (_rsURI s `combineIdAndRef` val)-  r <- RawSchema reference <$> H.lookup reference g-  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer-  p <- eitherToMaybe $ jsonPointer urlDecoded-  case resolvePointer p (Object $ _rsObject r) of-    Right (Object o) ->-      let compiled = compile spec g $ RawSchema (_rsURI r) o-      in Just $ either id (const mempty) . validate compiled-    _                -> Nothing-ref _ _ _ _ = Nothing--noVal :: ValidatorGen-noVal _ _ _ _ = Just (const mempty)

@@ -0,0 +1,11 @@++module Import (module Export) where++import           Control.Applicative as Export+import           Data.Aeson          as Export+import           Data.Foldable       as Export+import           Data.HashMap.Strict as Export (HashMap)+import           Data.Monoid         as Export+import           Data.Text           as Export (Text)+import           Data.Traversable    as Export+import           Data.Vector         as Export (Vector)

@@ -14,7 +14,6 @@ import           Data.Monoid import           Data.Text                      (Text) import qualified Data.Text                      as T-import           Data.Vector                    (Vector) import           System.FilePath                ((</>)) import           Test.Framework                 (Test) import           Test.Framework.Providers.HUnit (testCase)@@ -70,28 +69,38 @@ toTest :: SchemaTest -> Test toTest st =   testCase (T.unpack $ _stDescription st) $ do-    void . assertRight . isValidSchema $ _stSchema st+    sanityCheckTest (_stSchema st)     forM_ (_stCases st) $ \sc -> do-      g <- assertRight =<< fetchRefs draft4 (_stSchema st) H.empty+      g <- assertRight =<< fetchReferencedSchemas draft4 (_stSchema st) H.empty       let res = validate (compile draft4 g $ _stSchema st) (_scData sc)       if _scValid sc         then assertValid   sc res         else assertInvalid sc res+  where+    sanityCheckTest :: RawSchema -> IO ()+    sanityCheckTest rs =+      case isValidSchema rs of+        []   -> return ()+        errs -> error $ unlines+                  [ "One of the test cases has a problem! "+                  , "Description: "         <> T.unpack (_stDescription st)+                  , "Validation failures: " <> show errs+                  ] -assertValid :: SchemaTestCase -> Either (Vector ValErr) Value -> Assertion-assertValid sc (Left es) =+assertValid :: SchemaTestCase -> [ValidationFailure Draft4Failure] -> Assertion+assertValid _ [] = return ()+assertValid sc errs =   assertFailure $ unlines     [ "    Failed to validate data"-    , "    Description: " <> T.unpack (_scDescription sc)-    , "    Data: "        <> show (_scData sc)-    , "    Errors: "      <> show es+    , "    Description: "         <> T.unpack (_scDescription sc)+    , "    Data: "                <> show (_scData sc)+    , "    Validation failures: " <> show errs     ]-assertValid _ _ = return () -assertInvalid :: SchemaTestCase -> Either (Vector ValErr) Value -> Assertion-assertInvalid sc (Right _) =+assertInvalid :: SchemaTestCase -> [ValidationFailure Draft4Failure] -> Assertion+assertInvalid sc [] =   assertFailure $ unlines-    [ "    Failed to invalidate data"+    [ "    Validated invalid data"     , "    Description: " <> T.unpack (_scDescription sc)     , "    Data: "        <> show (_scData sc)     ]