packages feed

hjsonschema 0.9.0.0 → 0.10.0.0

raw patch · 36 files changed

+1080/−797 lines, 36 filesdep +pcre-heavydep −regexprdep ~aesondep ~basedep ~file-embed

Dependencies added: pcre-heavy

Dependencies removed: regexpr

Dependency ranges changed: aeson, base, file-embed, filepath, hjsonpointer, http-client, semigroups, text, unordered-containers, vector

Files

+ JSON-Schema-Test-Suite/remotes/integer.json view
@@ -0,0 +1,3 @@+{+    "type": "integer"+}
+ JSON-Schema-Test-Suite/remotes/subSchemas.json view
@@ -0,0 +1,8 @@+{+    "integer": {+        "type": "integer"+    }, +    "refToInteger": {+        "$ref": "#/integer"+    }+}
README.md view
@@ -8,23 +8,21 @@  # Example -See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Example.hs).+See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs).  # Tests -## Install--`git submodule update --init`+Run all tests: -## Run+`stack test` -Will run self-contained:+Run only local tests: -`cabal test local`+`stack test hjsonschema:local` -Will start an HTTP server temporarily on port 1234:+Run remote tests (makes GETs to json-schema.org, also temporarily starts an HTTP server on port 1234): -`cabal test remote`+`stack test hjsonschema:remote`  # Details @@ -42,11 +40,13 @@  ## Bad Parts -+ Uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.++ Uses the [pcre-heavy](https://hackage.haskell.org/package/pcre-heavy) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.  ## Notes -+ `draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema).++ `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite).+++ `src/draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema).  ## Credits
changelog.txt view
@@ -1,3 +1,13 @@+# 0.10+++ Rewrite fetching internals.++ Fix reference resolution defects, add more tests.++ Switch to a Perl style regex library, which is closer to ECMAScript regexes+than the previous Posix style one.++ Add one-step validation functions ('fetchFilesystemAndValidate' and 'fetchHTTPAndValidate').++ Alias the validation failure type exported by 'Data.JsonSchema.Draft4' to+'Invalid', change its field names.+ # 0.9  + Partial rewrite. The API of the library has changed, see the examples
− draft4.json 
@@ -1,150 +0,0 @@-{-    "id": "http://json-schema.org/draft-04/schema#",-    "$schema": "http://json-schema.org/draft-04/schema#",-    "description": "Core schema meta-schema",-    "definitions": {-        "schemaArray": {-            "type": "array",-            "minItems": 1,-            "items": { "$ref": "#" }-        },-        "positiveInteger": {-            "type": "integer",-            "minimum": 0-        },-        "positiveIntegerDefault0": {-            "allOf": [ { "$ref": "#/definitions/positiveInteger" }, { "default": 0 } ]-        },-        "simpleTypes": {-            "enum": [ "array", "boolean", "integer", "null", "number", "object", "string" ]-        },-        "stringArray": {-            "type": "array",-            "items": { "type": "string" },-            "minItems": 1,-            "uniqueItems": true-        }-    },-    "type": "object",-    "properties": {-        "id": {-            "type": "string",-            "format": "uri"-        },-        "$schema": {-            "type": "string",-            "format": "uri"-        },-        "title": {-            "type": "string"-        },-        "description": {-            "type": "string"-        },-        "default": {},-        "multipleOf": {-            "type": "number",-            "minimum": 0,-            "exclusiveMinimum": true-        },-        "maximum": {-            "type": "number"-        },-        "exclusiveMaximum": {-            "type": "boolean",-            "default": false-        },-        "minimum": {-            "type": "number"-        },-        "exclusiveMinimum": {-            "type": "boolean",-            "default": false-        },-        "maxLength": { "$ref": "#/definitions/positiveInteger" },-        "minLength": { "$ref": "#/definitions/positiveIntegerDefault0" },-        "pattern": {-            "type": "string",-            "format": "regex"-        },-        "additionalItems": {-            "anyOf": [-                { "type": "boolean" },-                { "$ref": "#" }-            ],-            "default": {}-        },-        "items": {-            "anyOf": [-                { "$ref": "#" },-                { "$ref": "#/definitions/schemaArray" }-            ],-            "default": {}-        },-        "maxItems": { "$ref": "#/definitions/positiveInteger" },-        "minItems": { "$ref": "#/definitions/positiveIntegerDefault0" },-        "uniqueItems": {-            "type": "boolean",-            "default": false-        },-        "maxProperties": { "$ref": "#/definitions/positiveInteger" },-        "minProperties": { "$ref": "#/definitions/positiveIntegerDefault0" },-        "required": { "$ref": "#/definitions/stringArray" },-        "additionalProperties": {-            "anyOf": [-                { "type": "boolean" },-                { "$ref": "#" }-            ],-            "default": {}-        },-        "definitions": {-            "type": "object",-            "additionalProperties": { "$ref": "#" },-            "default": {}-        },-        "properties": {-            "type": "object",-            "additionalProperties": { "$ref": "#" },-            "default": {}-        },-        "patternProperties": {-            "type": "object",-            "additionalProperties": { "$ref": "#" },-            "default": {}-        },-        "dependencies": {-            "type": "object",-            "additionalProperties": {-                "anyOf": [-                    { "$ref": "#" },-                    { "$ref": "#/definitions/stringArray" }-                ]-            }-        },-        "enum": {-            "type": "array",-            "minItems": 1,-            "uniqueItems": true-        },-        "type": {-            "anyOf": [-                { "$ref": "#/definitions/simpleTypes" },-                {-                    "type": "array",-                    "items": { "$ref": "#/definitions/simpleTypes" },-                    "minItems": 1,-                    "uniqueItems": true-                }-            ]-        },-        "allOf": { "$ref": "#/definitions/schemaArray" },-        "anyOf": { "$ref": "#/definitions/schemaArray" },-        "oneOf": { "$ref": "#/definitions/schemaArray" },-        "not": { "$ref": "#" }-    },-    "dependencies": {-        "exclusiveMaximum": [ "maximum" ],-        "exclusiveMinimum": [ "minimum" ]-    },-    "default": {}-}
examples/CustomSchema.hs view
@@ -1,16 +1,21 @@-{-# LANGUAGE OverloadedStrings #-}---- | A custom schema made up of one validator from 'Data.Validator.Draft4'--- and one original validator.+-- | A custom schema specification using one validator from+-- 'Data.Validator.Draft4' and one original validator. -- -- This is a simple example because it doesn't allow references (so it -- doesn't need to define an 'embed' function @Schema -> [Schema]@ for use -- with 'fetchReferencedSchemas'.+--+-- For a full example see 'Data.JsonSchema.Draft4' and its submodules.+-- Code use between schema specifications will likely be OK but not great.+-- All the 'Data.Validator' code as well as the 'Data.JsonSchema.Fetch' code+-- is reusable, but there's a lot of boilerplate to tie it together.  module CustomSchema where +import           Control.Applicative import           Data.Aeson import           Data.Maybe             (maybeToList)+import           Data.Monoid import           Data.Text              (Text) import qualified Data.Text              as T @@ -21,7 +26,7 @@ oddLength :: Bool -> Text -> Maybe (FR.Failure () ) oddLength b t   | b == odd (T.length t) = Nothing-  | otherwise             = Just (FR.Failure () (Bool b) mempty)+  | otherwise             = Just (FR.Invalid () (Bool b) mempty)  data CustomError   = MaxLength@@ -34,8 +39,8 @@   , _schemaOddLength :: Maybe Bool   } --- | Since every 'Schema' is valid we don't need to bother defining something--- like 'Data.JsonSchema.Draft4.checkValidity' for this schema.+-- | If our 'Schema's themselves could be invalid we might want to write+-- something like 'Data.JsonSchema.Draft4.schemaValidityy' for them. validate :: Schema -> Value -> [FR.Failure CustomError] validate s (String x) = concat   [ f _schemaMaxLength (FR.setFailure MaxLength) (fmap maybeToList . VA.maxLength)@@ -56,7 +61,7 @@ example =   case validate schema badData of     [] -> error "We validated bad data."-    [FR.Failure OddLength _ _] -> putStrLn "Success."+    [FR.Invalid OddLength _ _] -> return () -- Success.     _ -> error "We got a different failure than expected."   where     schema :: Schema
+ examples/Full.hs view
@@ -0,0 +1,34 @@+-- | Step by step validation using 'D4.referencesViaFilesystem' and+-- 'D4.checkSchema'. This means the actual validation invovles no IO.++module Full where++import           Data.Aeson++import qualified Data.JsonSchema.Draft4 as D4++schema :: D4.Schema+schema = D4.emptySchema { D4._schemaRef = Just "./unique.json" }++schemaContext :: D4.SchemaWithURI D4.Schema+schemaContext = D4.SchemaWithURI+  { D4._swSchema = schema+  , D4._swURI    = Just "./examples/json/imaginary.json"+  }++badData :: Value+badData = toJSON (["foo", "foo"] :: [String])++example :: IO ()+example = do+  res <- D4.referencesViaFilesystem schemaContext+  case res of+    Left _      -> error "Couldn't fetch referenced schemas."+    Right references -> do+      let validate = case D4.checkSchema references schemaContext of+                       Left _  -> error "Not a valid schema."+                       Right f -> f+      case validate badData of+        [] -> error "We validated bad data."+        [D4.Invalid (D4.Ref D4.UniqueItems) _ _] -> return () -- Success.+        e -> error "We got a different failure than expected."
− examples/Main.hs 
@@ -1,19 +0,0 @@--module Main where--import qualified CustomSchema      as C-import qualified PrettyShowFailure as P-import qualified Standard          as S--main :: IO ()-main = do-  putStrLn "# Standard Example"-  S.example-  putStrLn ""--  putStrLn "# PrettyShowFailure Example"-  P.example-  putStrLn ""--  putStrLn "# CustomSchema Example"-  C.example
examples/PrettyShowFailure.hs view
@@ -1,4 +1,11 @@-{-# LANGUAGE OverloadedStrings #-}+-- | 'D4.Invalid's contain a JSON Pointer to the subset of the data that+-- caused validation to fail, but they don't contain that data itself.+--+-- If you want to display the invalid subset of the data here's how you+-- resolve the JSON Pointer (which has the field name+-- 'D4._invalidOffendingData') against the original data.+--+-- NOTE: You have to have hjsonpointer in your build-depends.  module PrettyShowFailure where @@ -11,35 +18,34 @@ badData :: Value badData = toJSON [1, 2 :: Int] -failure :: D4.Failure-failure = D4.Failure-  { D4._failureValidatorsCalled = D4.Items D4.MultipleOf-  , D4._failureFinalValidator   = Number 2-  , D4._failureOffendingData    = AP.Pointer [AP.Token "0"]+failure :: D4.Invalid+failure = D4.Invalid+  { D4._invalidValidatorsCalled = D4.Items D4.MultipleOf+  , D4._invalidFinalValidator   = Number 2+  , D4._invalidOffendingData    = AP.Pointer [AP.Token "0"]   } -subsetOfData :: Value-subsetOfData =-  -- This is the only really interesting part of this example. To resolve the-  -- pointer to the part of the data that triggered the validation failure we-  -- have to have hjsonpointer in our build-depends and use 'AP.resolve'.-  case AP.resolve (D4._failureOffendingData failure) badData of+example :: IO ()+example =+  case AP.resolve (D4._invalidOffendingData failure) badData of     Left _  -> error "Couldn't resolve pointer."-    Right v -> v+    Right _ -> return () -- Success. We could feed the 'Right' value into+                         -- the otherwise unused 'msg' if we wanted to+                         -- display it. -example :: IO ()-example = putStrLn . unlines $+msg :: Value -> String+msg subsetOfData = unlines   [ "Invalid data. Here's the sequence of validators that caught it:"   , ""-  , "  " <> show (D4._failureValidatorsCalled failure)+  , "  " <> show (D4._invalidValidatorsCalled failure)   , ""   , "Here's the contents of the final validator in that sequence:"   , ""-  , "  " <> show (D4._failureFinalValidator failure)+  , "  " <> show (D4._invalidFinalValidator failure)   , ""   , "Here's a JSON Pointer to the invalid part of the data:"   , ""-  , "  " <> show (D4._failureOffendingData failure)+  , "  " <> show (D4._invalidOffendingData failure)   , ""   , "Here's the invalid part of the data:"   , ""
+ examples/Simple.hs view
@@ -0,0 +1,39 @@+-- | Fetch any referenced schemas, check that our original schema is itself+-- valid, then validate our data.+--+-- To fetch schemas using HTTP instead of from the filesystem use+-- 'D4.fetchHTTPAndValidate'.++module Simple where++import           Data.Aeson+import qualified Data.List.NonEmpty as NE++import qualified Data.JsonSchema.Draft4 as D4++schema :: D4.Schema+schema = D4.emptySchema { D4._schemaRef = Just "./unique.json" }++schemaContext :: D4.SchemaWithURI D4.Schema+schemaContext = D4.SchemaWithURI+  { D4._swSchema = schema+  , D4._swURI    = Just "./examples/json/imaginary.json"+  -- ^ For this example we're pretending we found 'schema' at this location.+  -- Its relative links will be resolved from here.+  }++badData :: Value+badData = toJSON (["foo", "foo"] :: [String])++example :: IO ()+example = do+  res <- D4.fetchFilesystemAndValidate schemaContext badData+  case res of+    Right () -> error "We validated bad data."+    Left (D4.FVRead _) -> error ("Error fetching a referenced schema"+                                ++ " (either during IO or parsing).")+    Left (D4.FVSchema _) -> error "Our 'schema' itself was invalid."+    Left (D4.FVData failures) ->+      case NE.toList failures of+        [D4.Invalid (D4.Ref D4.UniqueItems) _ _] -> return () -- Success.+        _ -> error "Got more invalidation reasons than we expected."
− examples/Standard.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Standard where--import           Data.Aeson-import qualified Data.HashMap.Strict    as H-import qualified Data.Vector            as V--import qualified Data.JsonSchema.Draft4 as D4--schema :: D4.Schema-schema = D4.emptySchema { D4._schemaUniqueItems = Just True }--schemaContext :: D4.SchemaContext D4.Schema-schemaContext = D4.SchemaContext-  { D4._scURI    = Nothing-  -- ^ If your schema has relative references to other schemas-  -- then you'll need to give its URI here.-  , D4._scSchema = schema-  }--badData :: Value-badData = Array (V.fromList ["foo", "foo"])--example :: IO ()-example = do-  -- Since we know our schema doesn't reference any other schemas we could-  -- skip this step and use @SchemaCache schema mempty@ instead.-  ---  -- If we make a mistake and out schema does include references to other-  -- schemas then those references will always return 'D4.RefResolution'-  -- validation failures.-  cache <- makeCache--  let validate = case D4.checkSchema cache schemaContext of-                   Left _  -> error "Not a valid schema."-                   Right f -> f--  case validate badData of-    [] -> error "We validated bad data."-    [D4.Failure D4.UniqueItems _ _] -> putStrLn "Success."-    _ -> error "We got a different failure than expected."--  where-    makeCache :: IO (D4.SchemaCache D4.Schema)-    makeCache = do-      -- A HashMap of URIs (in the form of Text) to schemas.-      let currentlyStoredSchemas = H.empty-      res <- D4.fetchReferencedSchemas currentlyStoredSchemas schemaContext-      case res of-        Left _      -> error "Couldn't fetch referenced schemas."-        Right cache -> return cache
hjsonschema.cabal view
@@ -1,5 +1,5 @@ name:                   hjsonschema-version:                0.9.0.0+version:                0.10.0.0 synopsis:               JSON Schema library homepage:               https://github.com/seagreen/hjsonschema license:                MIT@@ -11,10 +11,11 @@ cabal-version:          >=1.10 tested-with:            GHC == 7.8.4, GHC == 7.10.2 extra-source-files:     changelog.txt-                        draft4.json+                        JSON-Schema-Test-Suite/remotes/*.json                         JSON-Schema-Test-Suite/tests/draft4/*.json                         README.md-                        tests/Shared.hs+                        src/draft4.json+                        test/Local/*.json  library   hs-source-dirs:       src@@ -44,37 +45,48 @@                       , base                 >= 4.7    && < 4.9                       , bytestring           >= 0.10   && < 0.11                       , containers           >= 0.5    && < 0.6-                      , file-embed           >= 0.0.8  && < 0.0.10+                      , file-embed           >= 0.0.8  && < 0.1+                      , filepath             >= 1.3    && < 1.5                       , hjsonpointer         >= 0.3    && < 0.4-                      , http-client          >= 0.4.9  && < 0.5+                      , http-client          >= 0.4    && < 0.5                       , http-types           >= 0.8    && < 0.10+                      , pcre-heavy           >= 1.0    && < 1.1                       , QuickCheck           >= 2.8.1  && < 2.9-                      , regexpr              >= 0.5    && < 0.6                       , scientific           >= 0.3    && < 0.4-                      , semigroups           >= 0.18.0 && < 0.19+                      , semigroups           >= 0.18   && < 0.19                       , unordered-containers >= 0.2    && < 0.3-                      , text                 >= 1.2    && < 1.3+                      , text                 >= 1.1    && < 1.3                       , vector               >= 0.10   && < 0.12  test-suite local   type:                 exitcode-stdio-1.0-  hs-source-dirs:       tests+  hs-source-dirs:       test+                        examples   main-is:              Local.hs-  other-modules:        Shared+  other-modules:        Local.Failure+                      , Local.Filesystem+                      , Local.Reference+                      , Shared+                      -- from ./examples:+                      , CustomSchema+                      , Full+                      , PrettyShowFailure+                      , Simple   default-language:     Haskell2010   ghc-options:          -Wall -fno-warn-orphans   default-extensions:   OverloadedStrings   build-depends:        aeson                       , base                       , bytestring+                      , filepath                       , hjsonpointer                       , hjsonschema+                      , semigroups                       , text                       , QuickCheck                       , unordered-containers                       , vector                       , directory            >= 1.2  && < 1.3-                      , filepath             >= 1.3  && < 1.5                       , HUnit                >= 1.2  && < 1.4                       , tasty                >= 0.11 && < 0.12                       , tasty-hunit          >= 0.9  && < 0.10@@ -82,7 +94,7 @@  test-suite remote   type:                 exitcode-stdio-1.0-  hs-source-dirs:       tests+  hs-source-dirs:       test   main-is:              Remote.hs   other-modules:        Shared   default-language:     Haskell2010@@ -92,32 +104,16 @@                       , async                       , base                       , bytestring+                      , filepath                       , hjsonschema                       , text                       , vector                       , directory-                      , filepath                       , HUnit                       , tasty                       , tasty-hunit                       , wai-app-static                       , warp--executable example-  hs-source-dirs:       examples-  main-is:              Main.hs-  other-modules:        CustomSchema-                      , PrettyShowFailure-                      , Standard-  default-language:     Haskell2010-  ghc-options:          -Wall-  build-depends:        aeson-                      , base-                      , hjsonpointer-                      , hjsonschema-                      , text-                      , unordered-containers-                      , vector  source-repository head   type:               git
src/Data/JsonSchema/Draft4.hs view
@@ -4,67 +4,133 @@ module Data.JsonSchema.Draft4   ( Schema(..)   , emptySchema-  , checkSchema +    -- * One-step validation+  , HTTPValidationFailure(..)+  , fetchHTTPAndValidate+  , FilesystemValidationFailure(..)+  , fetchFilesystemAndValidate+     -- * Fetching tools-  , SchemaContext(..)-  , SchemaCache(..)-  , fetchReferencedSchemas+  , SchemaWithURI(..)+  , ReferencedSchemas(..)+  , HTTPFailure(..)+  , referencesViaHTTP+  , FilesystemFailure(..)+  , referencesViaFilesystem      -- * Failure-  , Failure(..)+  , Invalid+  , FR.Failure(..)   , ValidatorChain(..)      -- * Other Draft 4 things exported just in case+  , checkSchema   , schemaValidity   , IN.runValidate+  , draft4Spec   ) where +import           Control.Applicative+import           Control.Arrow                   (left) import           Data.Aeson import qualified Data.ByteString.Lazy            as LBS import           Data.FileEmbed import qualified Data.HashMap.Strict             as H+import           Data.List.NonEmpty              (NonEmpty)+import qualified Data.List.NonEmpty              as N import           Data.Maybe                      (fromMaybe) -import           Data.JsonSchema.Draft4.Failure+import           Data.JsonSchema.Draft4.Failure  (Invalid, ValidatorChain(..)) import qualified Data.JsonSchema.Draft4.Internal as IN import           Data.JsonSchema.Draft4.Schema-import           Data.JsonSchema.Fetch           (SchemaCache(..),-                                                  SchemaContext(..),-                                                  URISchemaMap)+import           Data.JsonSchema.Fetch           (FilesystemFailure(..),+                                                  HTTPFailure(..),+                                                  ReferencedSchemas(..),+                                                  SchemaWithURI(..)) import qualified Data.JsonSchema.Fetch           as FE-import           Data.Validator.Reference        (baseAndFragment)-import           Import+import qualified Data.Validator.Failure          as FR --- | Check the validity of a schema and return a function to validate data.+data HTTPValidationFailure+  = HVRequest HTTPFailure+  | HVSchema  (NonEmpty Invalid)+  | HVData    (NonEmpty Invalid)+  deriving Show++fetchHTTPAndValidate+  :: SchemaWithURI Schema+  -> Value+  -> IO (Either HTTPValidationFailure ())+fetchHTTPAndValidate sw v = do+  res <- referencesViaHTTP sw+  pure (g =<< f =<< left HVRequest res)+  where+    f :: ReferencedSchemas Schema+      -> Either HTTPValidationFailure (Value -> [Invalid])+    f references = left HVSchema (checkSchema references sw)++    g :: (Value -> [Invalid]) -> Either HTTPValidationFailure ()+    g validate = case N.nonEmpty (validate v) of+                   Nothing       -> Right ()+                   Just failures -> Left (HVData failures)++data FilesystemValidationFailure+  = FVRead   FilesystemFailure+  | FVSchema (NonEmpty Invalid)+  | FVData   (NonEmpty Invalid)+  deriving Show++fetchFilesystemAndValidate+  :: SchemaWithURI Schema+  -> Value+  -> IO (Either FilesystemValidationFailure ())+fetchFilesystemAndValidate sw v = do+  res <- referencesViaFilesystem sw+  pure (g =<< f =<< left FVRead res)+  where+    f :: ReferencedSchemas Schema+      -> Either FilesystemValidationFailure (Value -> [Invalid])+    f references = left FVSchema (checkSchema references sw)++    g :: (Value -> [Invalid]) -> Either FilesystemValidationFailure ()+    g validate = case N.nonEmpty (validate v) of+                   Nothing       -> Right ()+                   Just failures -> Left (FVData failures)++-- | Check the that a schema itself is valid.+--+-- Return a function to validate data. checkSchema-  :: SchemaCache Schema-  -> SchemaContext Schema-  -> Either [Failure] (Value -> [Failure])-checkSchema sg sc =-  case schemaValidity (_scSchema sc) of-    [] -> Right (IN.runValidate sg sc)-    es -> Left es+  :: ReferencedSchemas Schema+  -> SchemaWithURI Schema+  -> Either (NonEmpty Invalid) (Value -> [Invalid])+checkSchema referenced schemaWithURI =+  case N.nonEmpty . schemaValidity . _swSchema $ schemaWithURI of+    Nothing       -> Right (IN.runValidate referenced schemaWithURI)+    Just failures -> Left failures -fetchReferencedSchemas-  :: URISchemaMap Schema-  -> SchemaContext Schema-  -> IO (Either Text (SchemaCache Schema))-fetchReferencedSchemas =-  FE.fetchReferencedSchemas IN.embedded _schemaId _schemaRef+draft4Spec :: FE.Spec Schema+draft4Spec = FE.Spec IN.embedded _schemaId _schemaRef --- | In normal situations just use 'checkSchema', which is a combination of--- 'schemaValidity' and 'runValidate'.-schemaValidity :: Schema -> [Failure]-schemaValidity = IN.runValidate cache (SchemaContext Nothing d4) . toJSON+referencesViaHTTP+  :: SchemaWithURI Schema+  -> IO (Either HTTPFailure (ReferencedSchemas Schema))+referencesViaHTTP = FE.referencesViaHTTP' draft4Spec++referencesViaFilesystem+  :: SchemaWithURI Schema+  -> IO (Either FilesystemFailure (ReferencedSchemas Schema))+referencesViaFilesystem = FE.referencesViaFilesystem' draft4Spec++-- | Check that a schema itself is valid.+schemaValidity :: Schema -> [Invalid]+schemaValidity = IN.runValidate referenced (SchemaWithURI d4 Nothing) . toJSON   where     d4 :: Schema     d4 = fromMaybe (error "Schema decode failed (this should never happen)")-       . decode . LBS.fromStrict $ $(embedFile "draft4.json")+       . decode . LBS.fromStrict $ $(embedFile "src/draft4.json") -    -- @fst . baseAndFragment@ is necessary to remove the trailing "#",-    -- otherwise cache lookups to resolve internal references will fail.-    cache :: SchemaCache Schema-    cache = SchemaCache d4 $ case _schemaId d4 >>= fst . baseAndFragment of-                               Nothing  -> mempty-                               Just uri -> H.singleton uri d4+    referenced :: ReferencedSchemas Schema+    referenced = ReferencedSchemas+                   d4+                   (H.singleton "http://json-schema.org/draft-04/schema" d4)
src/Data/JsonSchema/Draft4/Failure.hs view
@@ -1,24 +1,9 @@  module Data.JsonSchema.Draft4.Failure where -import qualified Data.Aeson.Pointer     as P- import qualified Data.Validator.Failure as FR-import           Import --- | A version of 'FR.Failure' specialized for JSON Schema Draft 4.-data Failure = Failure-  -- NOTE: We use a data type here instead of a newtype to provide a cleaner-  -- API for those importing only 'Data.JsonSchema.Draft4' (which should be-  -- the vast majority of users). Downsides: slower and hacky. I'd appreciate-  -- feedback on this.-  { _failureValidatorsCalled :: !ValidatorChain-  , _failureFinalValidator   :: !Value-  , _failureOffendingData    :: !P.Pointer-  } deriving (Eq, Show)--specializeForDraft4 :: FR.Failure ValidatorChain -> Failure-specializeForDraft4 (FR.Failure a b c) = Failure a b c+type Invalid = FR.Failure ValidatorChain  data ValidatorChain   = MultipleOf
src/Data/JsonSchema/Draft4/Internal.hs view
@@ -10,8 +10,8 @@  import           Data.JsonSchema.Draft4.Failure import           Data.JsonSchema.Draft4.Schema-import           Data.JsonSchema.Fetch          (SchemaCache(..),-                                                 SchemaContext(..))+import           Data.JsonSchema.Fetch          (ReferencedSchemas(..),+                                                 SchemaWithURI(..)) import qualified Data.Validator.Draft4.Any      as AN import qualified Data.Validator.Draft4.Array    as AR import qualified Data.Validator.Draft4.Number   as NU@@ -19,7 +19,7 @@ import qualified Data.Validator.Draft4.String   as ST import           Data.Validator.Failure         (modFailure, setFailure) import qualified Data.Validator.Failure         as FR-import           Data.Validator.Reference       (newResolutionScope)+import           Data.Validator.Reference       (updateResolutionScope) import           Import  -- For GHCs before 7.10:@@ -71,28 +71,15 @@     checkDependency (OB.SchemaDependency s)   = Just s  ----------------------------------------------------- * Validation (Exported from 'Data.JsonSchema.Draft4')------------------------------------------------------- | In normal situations just use 'checkSchema', which is a combination of--- 'schemaValidity' and 'runValidate'.-runValidate-  :: SchemaCache Schema-  -> SchemaContext Schema-  -> Value-  -> [Failure]-runValidate = (fmap.fmap.fmap.fmap) specializeForDraft4 validateAny---------------------------------------------------- -- * Validation (Main internal functions) -------------------------------------------------- -validateAny-  :: SchemaCache Schema-  -> SchemaContext Schema+runValidate+  :: ReferencedSchemas Schema+  -> SchemaWithURI Schema   -> Value-  -> [FR.Failure ValidatorChain]-validateAny cache sc x = concat+  -> [Invalid]+runValidate referenced sw x = concat   [ f _schemaEnum  (setFailure Enum)          (fmap maybeToList . AN.enumVal)   , f _schemaType  (setFailure TypeValidator) (fmap maybeToList . AN.typeVal)   , f _schemaAllOf (modFailure AllOf)         (AN.allOf recurse)@@ -102,48 +89,48 @@   , refFailures   ] <> specificValidators   where-    specificValidators :: [FR.Failure ValidatorChain]+    specificValidators :: [Invalid]     specificValidators =       case x of-        Number y -> validateNumber (_scSchema sc) y-        String y -> validateString (_scSchema sc) y-        Array y  -> validateArray cache sc y-        Object y -> validateObject cache sc y+        Number y -> validateNumber (_swSchema sw) y+        String y -> validateString (_swSchema sw) y+        Array y  -> validateArray referenced sw y+        Object y -> validateObject referenced sw y         _        -> mempty -    f = runSingle (_scSchema sc) x+    f = runSingle (_swSchema sw) x -    recurse = descendNextLevel cache sc+    recurse = descendNextLevel referenced sw      -- Since the results of the 'AN.ref' validator are fairly complicated [1]     -- it's simpler not to use our 'f' helper function for it.     --     -- [1] A list of errors wrapped in a 'Maybe' where 'Nothing' represents     -- if resolving the reference itself failed.-    refFailures :: [FR.Failure ValidatorChain]+    refFailures :: [Invalid]     refFailures =-      case _schemaRef (_scSchema sc) of+      case _schemaRef (_swSchema sw) of         Nothing        -> mempty         Just reference ->-          maybe [FR.Failure RefResolution (toJSON reference) mempty]+          maybe [FR.Invalid RefResolution (toJSON reference) mempty]                 (fmap (modFailure Ref))                 $ AN.ref scope                          getReference-                         (\a b -> validateAny cache (SchemaContext a b))+                         (\a b -> runValidate referenced (SchemaWithURI b a))                          reference                          x       where         scope :: Maybe Text-        scope = newResolutionScope (_scURI sc) (_schemaId (_scSchema sc))+        scope = updateResolutionScope (_swURI sw) (_schemaId (_swSchema sw))          getReference :: Maybe Text -> Maybe Schema-        getReference Nothing  = Just (_startingSchema cache)-        getReference (Just t) = H.lookup t (_cachedSchemas cache)+        getReference Nothing  = Just (_rsStarting referenced)+        getReference (Just t) = H.lookup t (_rsSchemaMap referenced)  validateString   :: Schema   -> Text-  -> [FR.Failure ValidatorChain]+  -> [Invalid] validateString schema x = concat   [ f _schemaMaxLength (setFailure MaxLength)        (fmap maybeToList . ST.maxLength)   , f _schemaMinLength (setFailure MinLength)        (fmap maybeToList . ST.minLength)@@ -155,7 +142,7 @@ validateNumber   :: Schema   -> Scientific-  -> [FR.Failure ValidatorChain]+  -> [Invalid] validateNumber schema x = concat   [ f _schemaMultipleOf (setFailure MultipleOf) (fmap maybeToList . NU.multipleOf)   , f _schemaMaximum@@ -179,11 +166,11 @@     fMin NU.ExclusiveMinimum = ExclusiveMinimum  validateArray-  :: SchemaCache Schema-  -> SchemaContext Schema+  :: ReferencedSchemas Schema+  -> SchemaWithURI Schema   -> Vector Value-  -> [FR.Failure ValidatorChain]-validateArray cache (SchemaContext mUri schema) x = concat+  -> [Invalid]+validateArray referenced (SchemaWithURI schema mUri) x = concat   [ f _schemaMaxItems    (setFailure MaxItems)    (fmap maybeToList . AR.maxItems)   , f _schemaMinItems    (setFailure MinItems)    (fmap maybeToList . AR.minItems)   , f _schemaUniqueItems (setFailure UniqueItems) (fmap maybeToList . AR.uniqueItems)@@ -194,18 +181,18 @@   where     f = runSingle schema x -    recurse = descendNextLevel cache (SchemaContext mUri schema)+    recurse = descendNextLevel referenced (SchemaWithURI schema mUri)      fItems (AR.Items err)                        = Items err-    fItems AR.AdditionalItemsBoolFailure         = AdditionalItemsBool-    fItems (AR.AdditionalItemsObjectFailure err) = AdditionalItemsObject err+    fItems AR.AdditionalItemsBoolInvalid         = AdditionalItemsBool+    fItems (AR.AdditionalItemsObjectInvalid err) = AdditionalItemsObject err  validateObject-  :: SchemaCache Schema-  -> SchemaContext Schema+  :: ReferencedSchemas Schema+  -> SchemaWithURI Schema   -> HashMap Text Value-  -> [FR.Failure ValidatorChain]-validateObject cache (SchemaContext mUri schema) x = concat+  -> [Invalid]+validateObject referenced (SchemaWithURI schema mUri) x = concat   [ f _schemaMaxProperties (setFailure MaxProperties) (fmap maybeToList . OB.maxProperties)   , f _schemaMinProperties (setFailure MinProperties) (fmap maybeToList . OB.minProperties)   , f _schemaRequired      (setFailure Required)      (fmap maybeToList . OB.required)@@ -232,49 +219,49 @@   where     f = runSingle schema x -    recurse = descendNextLevel cache (SchemaContext mUri schema)+    recurse = descendNextLevel referenced (SchemaWithURI schema mUri) -    fDeps (OB.SchemaDependencyFailure err) = SchemaDependency err-    fDeps OB.PropertyDependencyFailure     = PropertyDependency+    fDeps (OB.SchemaDependencyInvalid err) = SchemaDependency err+    fDeps OB.PropertyDependencyInvalid     = PropertyDependency -    fProp (OB.PropertiesFailure err)   = Properties err-    fProp (OB.PropPatternFailure err)  = PatternProperties err-    fProp (OB.PropAdditionalFailure a) =+    fProp (OB.PropertiesInvalid err)   = Properties err+    fProp (OB.PropPatternInvalid err)  = PatternProperties err+    fProp (OB.PropAdditionalInvalid a) =       case a of-        OB.APBoolFailure       -> AdditionalPropertiesBool-        OB.APObjectFailure err -> AdditionalPropertiesObject err+        OB.APBoolInvalid       -> AdditionalPropertiesBool+        OB.APObjectInvalid err -> AdditionalPropertiesObject err -    fPatProp (OB.PPFailure err) = PatternProperties err-    fPatProp (OB.PPAdditionalPropertiesFailure a)   =+    fPatProp (OB.PPInvalid err) = PatternProperties err+    fPatProp (OB.PPAdditionalPropertiesInvalid a)   =       case a of-        OB.APBoolFailure       -> AdditionalPropertiesBool-        OB.APObjectFailure err -> AdditionalPropertiesObject err+        OB.APBoolInvalid       -> AdditionalPropertiesBool+        OB.APObjectInvalid err -> AdditionalPropertiesObject err -    fAddProp OB.APBoolFailure         = AdditionalPropertiesBool-    fAddProp (OB.APObjectFailure err) = AdditionalItemsObject err+    fAddProp OB.APBoolInvalid         = AdditionalPropertiesBool+    fAddProp (OB.APObjectInvalid err) = AdditionalItemsObject err  -------------------------------------------------- -- * Validation (Internal utils) --------------------------------------------------  descendNextLevel-  :: SchemaCache Schema-  -> SchemaContext Schema+  :: ReferencedSchemas Schema+  -> SchemaWithURI Schema   -> Schema   -> Value-  -> [FR.Failure ValidatorChain]-descendNextLevel cache (SchemaContext mUri schema) =-  validateAny cache . SchemaContext scope+  -> [Invalid]+descendNextLevel referenced (SchemaWithURI schema mUri) =+  runValidate referenced . flip SchemaWithURI scope   where     scope :: Maybe Text-    scope = newResolutionScope mUri (_schemaId schema)+    scope = updateResolutionScope mUri (_schemaId schema)  runSingle   :: Schema   -> dta   -> (Schema -> Maybe val)-  -> (err -> FR.Failure ValidatorChain)+  -> (err -> Invalid)   -> (val -> dta -> [err])-  -> [FR.Failure ValidatorChain]+  -> [Invalid] runSingle schema dta field modifyError validate =   maybe mempty (\val -> modifyError <$> validate val dta) (field schema)
src/Data/JsonSchema/Fetch.hs view
@@ -2,22 +2,34 @@  module Data.JsonSchema.Fetch where -import           Control.Exception        (SomeException(..), catch)+import           Control.Arrow            (left)+import           Control.Exception        (catch) import qualified Data.ByteString.Lazy     as LBS+import qualified Data.ByteString          as BS import qualified Data.HashMap.Strict      as H import qualified Data.Text                as T import           Network.HTTP.Client -import           Data.Validator.Reference (isRemoteReference,-                                           newResolutionScope,-                                           resolveReference)+import           Data.Validator.Reference (resolveReference,+                                           updateResolutionScope) import           Import  -- For GHCs before 7.10: import           Prelude                  hiding (concat, sequence) -data SchemaContext schema = SchemaContext-  { _scURI    :: !(Maybe Text)+--------------------------------------------------+-- * Types+--------------------------------------------------++data Spec schema = Spec+  { _ssEmbedded :: schema -> [schema]+  , _ssGetId    :: schema -> Maybe Text+  , _ssGetRef   :: schema -> Maybe Text+  }++data SchemaWithURI schema = SchemaWithURI+  { _swSchema :: !schema+  , _swURI    :: !(Maybe Text)   -- ^ Must not include a URI fragment, e.g. use   -- "http://example.com/foo" not "http://example.com/foo#bar".   --@@ -26,108 +38,136 @@   -- when resolving references contained in the schema.    -- TODO: Make the no URI fragment requirement unnecessary.--  , _scSchema :: !schema   } deriving (Eq, Show)  -- | Keys are URIs (without URI fragments). type URISchemaMap schema = HashMap Text schema -data SchemaCache schema = SchemaCache-  { _startingSchema :: !schema+data ReferencedSchemas schema = ReferencedSchemas+  { _rsStarting  :: !schema   -- ^ Used to resolve relative references.-  , _cachedSchemas  :: !(URISchemaMap schema)+  , _rsSchemaMap :: !(URISchemaMap schema)   } deriving (Eq, Show) +--------------------------------------------------+-- * Fetch via HTTP+--------------------------------------------------++data HTTPFailure+  = HTTPParseFailure   Text+  | HTTPRequestFailure HttpException+  deriving Show+ -- | Take a schema. Retrieve every document either it or its subschemas--- include via the "$ref" keyword. Load a 'SchemaCache' out with them.-fetchReferencedSchemas+-- include via the "$ref" keyword.+referencesViaHTTP'   :: forall schema. FromJSON schema-  => (schema -> [schema])-  -> (schema -> Maybe Text)-  -> (schema -> Maybe Text)-  -> URISchemaMap schema-  -> SchemaContext schema-  -> IO (Either Text (SchemaCache schema))-fetchReferencedSchemas embedded getId getRef cache sc = do+  => Spec schema+  -> SchemaWithURI schema+  -> IO (Either HTTPFailure (ReferencedSchemas schema))+referencesViaHTTP' spec sw = do   manager <- newManager defaultManagerSettings-  catch (Right <$> f manager) handler+  let f = referencesMethodAgnostic (get manager) spec sw+  catch (left HTTPParseFailure <$> f) handler   where-    f manager = fetchReferencedSchemas' embedded getId getRef-                                        (simpleGET manager) cache sc+    get :: Manager -> Text -> IO LBS.ByteString+    get man url = do+      request <- parseUrl (T.unpack url)+      responseBody <$> httpLbs request man -    handler :: SomeException -> IO (Either Text (SchemaCache schema))-    handler e = pure . Left . T.pack . show $ e+    handler+      :: HttpException+      -> IO (Either HTTPFailure (ReferencedSchemas schema))+    handler = pure . Left . HTTPRequestFailure --- | Based on 'Network.Http.Conduit.simpleHttp' from http-conduit.-simpleGET :: Manager -> Text -> IO LBS.ByteString-simpleGET man url = do-  req <- parseUrl (T.unpack url)-  responseBody <$> httpLbs req { requestHeaders = ("Connection", "close")-                               : requestHeaders req-                               } man+--------------------------------------------------+-- * Fetch via Filesystem+-------------------------------------------------- +data FilesystemFailure+  = FSParseFailure Text+  | FSReadFailure  IOError+  deriving Show++referencesViaFilesystem'+  :: forall schema. FromJSON schema+  => Spec schema+  -> SchemaWithURI schema+  -> IO (Either FilesystemFailure (ReferencedSchemas schema))+referencesViaFilesystem' spec sw = catch (left FSParseFailure <$> f) handler+  where+    f :: IO (Either Text (ReferencedSchemas schema))+    f = referencesMethodAgnostic readFile' spec sw++    readFile' :: Text -> IO LBS.ByteString+    readFile' = fmap LBS.fromStrict . BS.readFile . T.unpack++    handler+      :: IOError+      -> IO (Either FilesystemFailure (ReferencedSchemas schema))+    handler = pure . Left . FSReadFailure++--------------------------------------------------+-- * Method Agnostic Fetching Tools+--------------------------------------------------+ -- | A version of 'fetchReferencedSchema's where the function to fetch -- schemas is provided by the user. This allows restrictions to be added, -- e.g. rejecting non-local URIs.-fetchReferencedSchemas'+referencesMethodAgnostic   :: forall schema. FromJSON schema-  => (schema -> [schema])-  -> (schema -> Maybe Text)-  -> (schema -> Maybe Text)-  -> (Text -> IO LBS.ByteString)+  => (Text -> IO LBS.ByteString)+  -> Spec schema+  -> SchemaWithURI schema+  -> IO (Either Text (ReferencedSchemas schema))+referencesMethodAgnostic fetchRef spec sw =+  (fmap.fmap) (ReferencedSchemas (_swSchema sw))+              (foldFunction fetchRef spec mempty sw)++foldFunction+  :: forall schema. FromJSON schema+  => (Text -> IO LBS.ByteString)+  -> Spec schema   -> URISchemaMap schema-  -> SchemaContext schema-  -> IO (SchemaCache schema)-fetchReferencedSchemas' embedded getId getRef fetchRef cache sc = do-  let startingCache = case _scURI sc of-                        Nothing  -> cache-                        Just uri -> H.insert uri (_scSchema sc) cache-  SchemaCache (_scSchema sc) <$> foldlM fetchRecursively-                                        startingCache-                                        (includeSubschemas embedded getId sc)+  -> SchemaWithURI schema+  -> IO (Either Text (URISchemaMap schema))+foldFunction fetchRef spec@(Spec _ _ getRef) referenced sw =+  foldlM f (Right referenced) (includeSubschemas spec sw)   where-    fetchRecursively-      :: URISchemaMap schema-      -> SchemaContext schema-      -> IO (URISchemaMap schema)-    fetchRecursively g (SchemaContext mUri schema) = do-      -- Resolving the new scope is necessary here because of situations-      -- like this:-      ---      -- {-      --     "id": "http://localhost:1234/",-      --     "items": {-      --         "id": "folder/",-      --         "items": {"$ref": "folderInteger.json"}-      --     }-      -- }-      let scope = newResolutionScope mUri (getId schema)-      case resolveReference scope <$> getRef schema of-        Just (Just uri,_) ->-          if not (isRemoteReference uri) || H.member uri g-            then pure g-            else do-              bts <- fetchRef uri-              case eitherDecode bts of-                Left e     -> ioError (userError e)-                Right schm -> _cachedSchemas <$>-                  fetchReferencedSchemas' embedded getId getRef fetchRef-                                          g (SchemaContext (Just uri) schm)-        _ -> pure g+    f :: Either Text (URISchemaMap schema)+      -> SchemaWithURI schema+      -> IO (Either Text (URISchemaMap schema))+    f (Left e) _                            = pure (Left e)+    f (Right g) (SchemaWithURI schema mUri) =+      case newRef of+        Nothing  -> pure (Right g)+        Just uri -> do+          bts <- fetchRef uri+          case eitherDecode bts of+            Left e     -> pure . Left . T.pack $ e+            Right schm -> foldFunction fetchRef spec (H.insert uri schm g)+                                       (SchemaWithURI schm (Just uri))+      where+        newRef :: Maybe Text+        newRef+          | Just (Just uri,_) <- resolveReference mUri <$> getRef schema+            = case H.lookup uri g of+                Nothing -> Just uri+                Just _  -> Nothing+          | otherwise = Nothing  -- | Return the schema passed in as an argument, as well as every -- subschema contained within it. includeSubschemas   :: forall schema.-     (schema -> [schema])-  -> (schema -> Maybe Text)-  -> SchemaContext schema-  -> [SchemaContext schema]-includeSubschemas embedded getId (SchemaContext mUri schema) =-  SchemaContext mUri schema-  : (includeSubschemas embedded getId =<< subSchemas)+     Spec schema+  -> SchemaWithURI schema+  -> [SchemaWithURI schema]+includeSubschemas spec@(Spec embedded getId _) (SchemaWithURI schema mUri) =+  SchemaWithURI schema mUri+  : (includeSubschemas spec =<< subSchemas)   where-    subSchemas :: [SchemaContext schema]-    subSchemas = SchemaContext (newResolutionScope mUri (getId schema))-             <$> embedded schema+    subSchemas :: [SchemaWithURI schema]+    subSchemas =+      (\a -> SchemaWithURI a (updateResolutionScope mUri (getId schema)))+        <$> embedded schema
src/Data/Validator/Draft4/Any.hs view
@@ -12,11 +12,11 @@  import           Data.Validator.Failure import           Data.Validator.Utils-import           Data.Validator.Reference+import           Data.Validator.Reference (resolveFragment, resolveReference) import           Import  -- For GHCs before 7.10:-import           Prelude hiding           (any)+import           Prelude hiding           (any, elem)  -------------------------------------------------- -- * $ref@@ -81,11 +81,10 @@  enumVal :: EnumVal -> Value -> Maybe (Failure ()) enumVal (EnumVal vs) x-  | null vs                   = Nothing   | not (allUniqueValues' vs) = Nothing   | x `elem` vs               = Nothing   | otherwise                 =-    Just $ Failure () (toJSON (NonEmpty' vs)) mempty+    Just $ Invalid () (toJSON (NonEmpty' vs)) mempty  -------------------------------------------------- -- * type@@ -115,7 +114,7 @@  isJsonType :: Value -> Set Text -> Maybe (Failure ()) isJsonType x ts-  | S.null (S.intersection okTypes ts) = Just (Failure () (toJSON ts) mempty)+  | S.null (S.intersection okTypes ts) = Just (Invalid () (toJSON ts) mempty)   | otherwise                          = Nothing   where     okTypes :: Set Text@@ -150,7 +149,7 @@   -> Maybe (Failure ()) anyOf f subSchemas x   | any null (flip f x <$> subSchemas) = Nothing-  | otherwise = Just $ Failure () (toJSON (NonEmpty' subSchemas)) mempty+  | otherwise = Just $ Invalid () (toJSON (NonEmpty' subSchemas)) mempty  oneOf   :: forall err schema. ToJSON schema@@ -160,7 +159,7 @@   -> Maybe (Failure ()) oneOf f subSchemas x   | length successes == 1 = Nothing-  | otherwise             = Just $ Failure ()+  | otherwise             = Just $ Invalid ()                                            (toJSON (NonEmpty' subSchemas))                                            mempty   where@@ -175,5 +174,5 @@   -> Maybe (Failure ()) notVal f schema x =   case f schema x of-    [] -> Just (Failure () (toJSON schema) mempty)+    [] -> Just (Invalid () (toJSON schema) mempty)     _  -> Nothing
src/Data/Validator/Draft4/Array.hs view
@@ -15,30 +15,30 @@ maxItems :: Int -> Vector Value -> Maybe (Failure ()) maxItems n xs   | n < 0           = Nothing-  | V.length xs > n = Just (Failure () (toJSON n) mempty)+  | V.length xs > n = Just (Invalid () (toJSON n) mempty)   | otherwise       = Nothing  -- | The spec requires "minItems" to be non-negative. minItems :: Int -> Vector Value -> Maybe (Failure ()) minItems n xs   | n < 0           = Nothing-  | V.length xs < n = Just (Failure () (toJSON n) mempty)+  | V.length xs < n = Just (Invalid () (toJSON n) mempty)   | otherwise       = Nothing  uniqueItems :: Bool -> Vector Value -> Maybe (Failure ()) uniqueItems True xs   | allUniqueValues xs = Nothing-  | otherwise          = Just (Failure () (Bool True) mempty)+  | otherwise          = Just (Invalid () (Bool True) mempty) uniqueItems False _ = Nothing  -------------------------------------------------- -- * items -------------------------------------------------- -data ItemsFailure err+data ItemsInvalid err   = Items err-  | AdditionalItemsBoolFailure-  | AdditionalItemsObjectFailure err+  | AdditionalItemsBoolInvalid+  | AdditionalItemsObjectInvalid err   deriving (Eq, Show)  data Items schema@@ -65,10 +65,10 @@   -> Maybe (AdditionalItems schema)   -> Items schema   -> Vector Value-  -> [Failure (ItemsFailure err)]+  -> [Failure (ItemsInvalid err)] items f _ (ItemsObject subSchema) xs = zip [0..] (V.toList xs) >>= g   where-    g :: (Int, Value) -> [Failure (ItemsFailure err)]+    g :: (Int, Value) -> [Failure (ItemsInvalid err)]     g (index,x) = modFailure Items                 . addToPath (P.Token (T.pack (show index)))               <$> f subSchema x@@ -79,15 +79,15 @@     indexedValues :: [(Int, Value)]     indexedValues = zip [0..] (V.toList xs) -    itemFailures :: [Failure (ItemsFailure err)]+    itemFailures :: [Failure (ItemsInvalid err)]     itemFailures = join (zipWith g subSchemas indexedValues)       where-        g :: schema -> (Int, Value) -> [Failure (ItemsFailure err)]+        g :: schema -> (Int, Value) -> [Failure (ItemsInvalid err)]         g schema (index,x) = modFailure Items                            . addToPath (P.Token (T.pack (show index)))                          <$> f schema x -    additionalItemFailures :: [Failure (ItemsFailure err)]+    additionalItemFailures :: [Failure (ItemsInvalid err)]     additionalItemFailures =       case mAdditional of         Nothing  -> mempty@@ -105,9 +105,9 @@         -- represent invalid data so they actually represent the correct         -- offsets.         correctIndexes-          :: Failure (AdditionalItemsFailure err)-          -> Failure (AdditionalItemsFailure err)-        correctIndexes (Failure a b c) = Failure a b (fixIndex c)+          :: Failure (AdditionalItemsInvalid err)+          -> Failure (AdditionalItemsInvalid err)+        correctIndexes (Invalid a b c) = Invalid a b (fixIndex c)           where             fixIndex :: P.Pointer -> P.Pointer             fixIndex (P.Pointer (tok:toks)) =@@ -117,18 +117,18 @@                   (P.Token . T.pack . show $ n + length subSchemas):toks             fixIndex (P.Pointer []) = P.Pointer [] -        correctName :: AdditionalItemsFailure err -> ItemsFailure err-        correctName AdditionalBoolFailure = AdditionalItemsBoolFailure-        correctName (AdditionalObjectFailure err) =-          AdditionalItemsObjectFailure err+        correctName :: AdditionalItemsInvalid err -> ItemsInvalid err+        correctName AdditionalBoolInvalid = AdditionalItemsBoolInvalid+        correctName (AdditionalObjectInvalid err) =+          AdditionalItemsObjectInvalid err  -------------------------------------------------- -- * additionalItems -------------------------------------------------- -data AdditionalItemsFailure err-  = AdditionalBoolFailure-  | AdditionalObjectFailure err+data AdditionalItemsInvalid err+  = AdditionalBoolInvalid+  | AdditionalObjectInvalid err   deriving (Eq, Show)  data AdditionalItems schema@@ -154,15 +154,15 @@      (schema -> Value -> [Failure err])   -> AdditionalItems schema   -> Vector Value-  -> [Failure (AdditionalItemsFailure err)]+  -> [Failure (AdditionalItemsInvalid err)] additionalItems _ (AdditionalBool b) xs   | b               = mempty-  | V.length xs > 0 = pure (Failure AdditionalBoolFailure (Bool b) mempty)+  | V.length xs > 0 = pure (Invalid AdditionalBoolInvalid (Bool b) mempty)   | otherwise       = mempty additionalItems f (AdditionalObject subSchema) xs =   zip [0..] (V.toList xs) >>= g   where-    g :: (Int, Value) -> [Failure (AdditionalItemsFailure err)]-    g (index,x) = modFailure AdditionalObjectFailure+    g :: (Int, Value) -> [Failure (AdditionalItemsInvalid err)]+    g (index,x) = modFailure AdditionalObjectInvalid                 . addToPath (P.Token (T.pack (show index)))               <$> f subSchema x
src/Data/Validator/Draft4/Number.hs view
@@ -11,10 +11,10 @@ multipleOf :: Scientific -> Scientific -> Maybe (Failure ()) multipleOf n x   | n <= 0          = Nothing-  | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty)+  | x `mod'` n /= 0 = Just (Invalid () (toJSON n) mempty)   | otherwise       = Nothing -data MaximumFailure+data MaximumInvalid   = Maximum   | ExclusiveMaximum   deriving (Eq, Show)@@ -23,16 +23,16 @@   :: Bool   -> Scientific   -> Scientific-  -> Maybe (Failure MaximumFailure)+  -> Maybe (Failure MaximumInvalid) maximumVal exclusiveMaximum n x-  | x `greaterThan` n = Just (Failure err (toJSON n) mempty)+  | x `greaterThan` n = Just (Invalid err (toJSON n) mempty)   | otherwise         = Nothing   where     (greaterThan, err) = if exclusiveMaximum                            then ((>=), ExclusiveMaximum)                            else ((>), Maximum) -data MinimumFailure+data MinimumInvalid   = Minimum   | ExclusiveMinimum   deriving (Eq, Show)@@ -41,9 +41,9 @@   :: Bool   -> Scientific   -> Scientific-  -> Maybe (Failure MinimumFailure)+  -> Maybe (Failure MinimumInvalid) minimumVal exclusiveMinimum n x-  | x `lessThan` n = Just (Failure err (toJSON n) mempty)+  | x `lessThan` n = Just (Invalid err (toJSON n) mempty)   | otherwise      = Nothing   where     (lessThan, err) = if exclusiveMinimum
src/Data/Validator/Draft4/Object.hs view
@@ -25,14 +25,14 @@ maxProperties :: Int -> HashMap Text Value -> Maybe (Failure ()) maxProperties n x   | n < 0        = Nothing-  | H.size x > n = Just (Failure () (toJSON n) mempty)+  | H.size x > n = Just (Invalid () (toJSON n) mempty)   | otherwise    = Nothing  -- | The spec requires "minProperties" to be non-negative. minProperties :: Int -> HashMap Text Value -> Maybe (Failure ()) minProperties n x   | n < 0        = Nothing-  | H.size x < n = Just (Failure () (toJSON n) mempty)+  | H.size x < n = Just (Invalid () (toJSON n) mempty)   | otherwise    = Nothing  --------------------------------------------------@@ -80,7 +80,7 @@   -- instead of specialized versions.   | S.null ts                  = Nothing   | H.null (H.difference hm x) = Nothing-  | otherwise                  = Just (Failure () (toJSON ts) mempty)+  | otherwise                  = Just (Invalid () (toJSON ts) mempty)   where     hm :: HashMap Text Bool     hm = foldl (\b a -> H.insert a True b) mempty ts@@ -89,9 +89,9 @@ -- * dependencies -------------------------------------------------- -data DependencyFailure err-  = SchemaDependencyFailure err-  | PropertyDependencyFailure+data DependencyInvalid err+  = SchemaDependencyInvalid err+  | PropertyDependencyInvalid   deriving (Eq, Show)  data Dependency schema@@ -128,17 +128,17 @@   :: forall err schema. (schema -> Value -> [Failure err])   -> HashMap Text (Dependency schema)   -> HashMap Text Value-  -> [Failure (DependencyFailure err)]+  -> [Failure (DependencyInvalid err)] dependencies f hm x = concat . fmap (uncurry g) . H.toList $ hm   where-    g :: Text -> Dependency schema -> [Failure (DependencyFailure err)]+    g :: Text -> Dependency schema -> [Failure (DependencyInvalid err)]     g k (SchemaDependency schema)       | H.member k x =-        modFailure SchemaDependencyFailure <$> f schema (Object x)+        modFailure SchemaDependencyInvalid <$> f schema (Object x)       | otherwise    = mempty     g k (PropertyDependency ts)       | H.member k x && not allPresent =-        pure $ Failure PropertyDependencyFailure+        pure $ Invalid PropertyDependencyInvalid                        (toJSON (H.singleton k ts))                        mempty       | otherwise = mempty
src/Data/Validator/Draft4/Object/Properties.hs view
@@ -7,7 +7,8 @@ import qualified Data.Aeson.Pointer     as P import qualified Data.HashMap.Strict    as H import qualified Data.Text              as T-import           Text.RegexPR+import           Data.Text.Encoding     (encodeUtf8)+import qualified Text.Regex.PCRE.Heavy  as RE  import           Data.Validator.Failure import           Import@@ -18,10 +19,10 @@ -- * properties -------------------------------------------------- -data PropertiesFailure err-  = PropertiesFailure err-  | PropPatternFailure err-  | PropAdditionalFailure (AdditionalPropertiesFailure err)+data PropertiesInvalid err+  = PropertiesInvalid err+  | PropPatternInvalid err+  | PropAdditionalInvalid (AdditionalPropertiesInvalid err)   deriving (Eq, Show)  -- | In order of what's tried: "properties", "patternProperties",@@ -33,11 +34,11 @@   -> Maybe (AdditionalProperties schema)   -> HashMap Text schema   -> HashMap Text Value-  -> [Failure (PropertiesFailure err)]+  -> [Failure (PropertiesInvalid err)] properties f mPat mAdd propertiesHm x =-     fmap (modFailure PropertiesFailure) propFailures-  <> fmap (modFailure PropPatternFailure) patternFailures-  <> fmap (modFailure PropAdditionalFailure) additionalFailures+     fmap (modFailure PropertiesInvalid) propFailures+  <> fmap (modFailure PropPatternInvalid) patternFailures+  <> fmap (modFailure PropAdditionalInvalid) additionalFailures   where     propertiesAndUnmatched :: ([Failure err], Remaining)     propertiesAndUnmatched = ( failures@@ -63,7 +64,7 @@                    Nothing  -> remaining1                    Just val -> snd . val . _unRemaining $ remaining1 -    additionalFailures :: [Failure (AdditionalPropertiesFailure err)]+    additionalFailures :: [Failure (AdditionalPropertiesInvalid err)]     additionalFailures = case additionalProperties f <$> mAdd of                            Nothing  -> mempty                            Just val -> val (_unRemaining remaining2)@@ -72,9 +73,9 @@ -- * patternProperties -------------------------------------------------- -data PatternPropertiesFailure err-  = PPFailure err-  | PPAdditionalPropertiesFailure (AdditionalPropertiesFailure err)+data PatternPropertiesInvalid err+  = PPInvalid err+  | PPAdditionalPropertiesInvalid (AdditionalPropertiesInvalid err)   deriving (Eq, Show)  patternProperties@@ -83,17 +84,17 @@   -> Maybe (AdditionalProperties schema)   -> HashMap Text schema   -> HashMap Text Value-  -> [Failure (PatternPropertiesFailure err)]+  -> [Failure (PatternPropertiesInvalid err)] patternProperties f mAdd patternPropertiesHm x =-     fmap (modFailure PPFailure) ppFailures-  <> fmap (modFailure PPAdditionalPropertiesFailure) addFailures+     fmap (modFailure PPInvalid) ppFailures+  <> fmap (modFailure PPAdditionalPropertiesInvalid) addFailures   where     patternProps :: ([Failure err], Remaining)     patternProps = patternAndUnmatched f patternPropertiesHm x      (ppFailures, remaining) = patternProps -    addFailures :: [Failure (AdditionalPropertiesFailure err)]+    addFailures :: [Failure (AdditionalPropertiesInvalid err)]     addFailures = case additionalProperties f <$> mAdd of                     Nothing  -> mempty                     Just val -> val (_unRemaining remaining)@@ -126,9 +127,11 @@           -> schema           -> [schema]         checkKey k acc r subSchema =-          case matchRegexPR (T.unpack r) (T.unpack k) of-            Nothing -> acc-            Just _  -> pure subSchema <> acc+          case RE.compileM (encodeUtf8 r) mempty of+            Left _   -> acc+            Right re -> if k RE.=~ re+                          then pure subSchema <> acc+                          else acc      runVals       :: [Failure err]@@ -146,9 +149,9 @@ -- * additionalProperties -------------------------------------------------- -data AdditionalPropertiesFailure err-  = APBoolFailure-  | APObjectFailure err+data AdditionalPropertiesInvalid err+  = APBoolInvalid+  | APObjectInvalid err   deriving (Eq, Show)  data AdditionalProperties schema@@ -174,14 +177,14 @@      (schema -> Value -> [Failure err])   -> AdditionalProperties schema   -> HashMap Text Value-  -> [Failure (AdditionalPropertiesFailure err)]+  -> [Failure (AdditionalPropertiesInvalid err)] additionalProperties _ (AdditionalPropertiesBool False) x-  | H.size x > 0 = pure $ Failure APBoolFailure (Bool False) mempty+  | H.size x > 0 = pure $ Invalid APBoolInvalid (Bool False) mempty   | otherwise    = mempty additionalProperties _ (AdditionalPropertiesBool True) _ = mempty additionalProperties f (AdditionalPropertiesObject schema) x = H.toList x >>= g   where-    g :: (Text, Value) -> [Failure (AdditionalPropertiesFailure err)]-    g (k,v) = modFailure APObjectFailure+    g :: (Text, Value) -> [Failure (AdditionalPropertiesInvalid err)]+    g (k,v) = modFailure APObjectInvalid             . addToPath (P.Token k)           <$> f schema v
src/Data/Validator/Draft4/String.hs view
@@ -3,7 +3,8 @@  import           Data.Aeson import qualified Data.Text              as T-import           Text.RegexPR+import           Data.Text.Encoding     (encodeUtf8)+import qualified Text.Regex.PCRE.Heavy  as RE  import           Data.Validator.Failure import           Import@@ -12,18 +13,20 @@ maxLength :: Int -> Text -> Maybe (Failure ()) maxLength n x   | n <= 0         = Nothing-  | T.length x > n = Just (Failure () (toJSON n) mempty)+  | T.length x > n = Just (Invalid () (toJSON n) mempty)   | otherwise      = Nothing  -- | The spec requires "minLength" to be non-negative. minLength :: Int -> Text -> Maybe (Failure ()) minLength n x   | n <= 0         = Nothing-  | T.length x < n = Just (Failure () (toJSON n) mempty)+  | T.length x < n = Just (Invalid () (toJSON n) mempty)   | otherwise      = Nothing  patternVal :: Text -> Text -> Maybe (Failure ()) patternVal t x =-  case matchRegexPR (T.unpack t) (T.unpack x) of-    Nothing -> Just (Failure () (toJSON t) mempty)-    Just _  -> Nothing+  case RE.compileM (encodeUtf8 t) mempty of+    Left _   -> Just (Invalid () (toJSON t) mempty)+    Right re -> if x RE.=~ re+                  then Nothing+                  else Just (Invalid () (toJSON t) mempty)
src/Data/Validator/Failure.hs view
@@ -23,20 +23,20 @@ -- by the validators it uses into a single error sum type for that schema. -- The schema's validate function will return a 'ValidationFailure' with -- that sum type as its type argument.-data Failure err = Failure-  { _failureValidatorsCalled :: !err-  , _failureFinalValidator   :: !Value-  , _failureOffendingData    :: !P.Pointer+data Failure err = Invalid+  { _invalidValidatorsCalled :: !err+  , _invalidFinalValidator   :: !Value+  , _invalidOffendingData    :: !P.Pointer   } deriving (Eq, Show)  setFailure :: b -> Failure a -> Failure b-setFailure e (Failure _ a b) = Failure e a b+setFailure e (Invalid _ a b) = Invalid e a b  modFailure :: (a -> b) -> Failure a -> Failure b-modFailure f v@(Failure a _ _) = v { _failureValidatorsCalled = f a }+modFailure f v@(Invalid a _ _) = v { _invalidValidatorsCalled = f a }  addToPath :: P.Token -> Failure a -> Failure a-addToPath tok v@(Failure _ _ a) = v { _failureOffendingData = addToken a }+addToPath tok v@(Invalid _ _ a) = v { _invalidOffendingData = addToken a }   where     addToken :: P.Pointer -> P.Pointer     addToken (P.Pointer ts) = P.Pointer (ts <> pure tok)
src/Data/Validator/Reference.hs view
@@ -1,28 +1,43 @@ +-- | JSON Reference is described here:+-- <http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03>+--+-- And is extended for JSON Schema here:+-- <http://json-schema.org/latest/json-schema-core.html#anchor26>+--+-- Notes on where these functions are used:+--+--   * 'Data.JsonSchema.Fetch.includeSubschemas' uses 'updateResolutionScope'.+--+--   * 'Data.JsonSchema.Fetch.foldFunction' uses 'resolveReference'.+--+--   * 'Data.JsonSchema.Draft4.Internal' uses 'updateResolutionScope'+--     throughout.+--+--   * 'Data.Validator.Draft4.Any.ref' uses 'resolveReference' and+--     'resolveFragment'.+ module Data.Validator.Reference where  import qualified Data.Aeson.Pointer     as P import qualified Data.Text              as T import           Data.Text.Encoding-import           Network.HTTP.Types.URI+import           Network.HTTP.Types.URI (urlDecode)+import           System.FilePath        ((</>), dropFileName)  import           Import  type URIBase = Maybe Text type URIBaseAndFragment = (Maybe Text, Maybe Text) -newResolutionScope :: URIBase -> Maybe Text -> URIBase-newResolutionScope mScope idKeyword =-  case idKeyword of-    Just t -> fst . baseAndFragment $ resolveScopeAgainst mScope t-    _      -> mScope+updateResolutionScope :: URIBase -> Maybe Text -> URIBase+updateResolutionScope mScope idKeyword+  | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t+  | otherwise           = mScope  resolveReference :: URIBase -> Text -> URIBaseAndFragment resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t -isRemoteReference :: Text -> Bool-isRemoteReference uri = "://" `T.isInfixOf` uri- resolveFragment   :: (FromJSON schema, ToJSON schema, Show schema)   => Maybe Text@@ -38,9 +53,12 @@     Success schema' -> Just schema'  ----------------------------------------------------- * Internal+-- * Helpers -------------------------------------------------- +isRemoteReference :: Text -> Bool+isRemoteReference = T.isInfixOf "://"+ baseAndFragment :: Text -> URIBaseAndFragment baseAndFragment = f . T.splitOn "#"   where@@ -62,6 +80,12 @@     -- but just in case a user leaves one in we want to be sure     -- to cut it off before appending.     smartAppend :: Text-    smartAppend = case baseAndFragment scope of-                    (Just base,_) -> base <> t-                    _             -> t+    smartAppend =+      case baseAndFragment scope of+        (Just base,_) ->+          case T.unpack t of+            -- We want "/foo" and "#/bar" to combine into+            -- "/foo#/bar" not "/foo/#/bar".+            '#':_ -> base <> t+            _     -> T.pack (dropFileName (T.unpack base) </> T.unpack t)+        _ -> t
+ src/draft4.json view
@@ -0,0 +1,150 @@+{+    "id": "http://json-schema.org/draft-04/schema#",+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "Core schema meta-schema",+    "definitions": {+        "schemaArray": {+            "type": "array",+            "minItems": 1,+            "items": { "$ref": "#" }+        },+        "positiveInteger": {+            "type": "integer",+            "minimum": 0+        },+        "positiveIntegerDefault0": {+            "allOf": [ { "$ref": "#/definitions/positiveInteger" }, { "default": 0 } ]+        },+        "simpleTypes": {+            "enum": [ "array", "boolean", "integer", "null", "number", "object", "string" ]+        },+        "stringArray": {+            "type": "array",+            "items": { "type": "string" },+            "minItems": 1,+            "uniqueItems": true+        }+    },+    "type": "object",+    "properties": {+        "id": {+            "type": "string",+            "format": "uri"+        },+        "$schema": {+            "type": "string",+            "format": "uri"+        },+        "title": {+            "type": "string"+        },+        "description": {+            "type": "string"+        },+        "default": {},+        "multipleOf": {+            "type": "number",+            "minimum": 0,+            "exclusiveMinimum": true+        },+        "maximum": {+            "type": "number"+        },+        "exclusiveMaximum": {+            "type": "boolean",+            "default": false+        },+        "minimum": {+            "type": "number"+        },+        "exclusiveMinimum": {+            "type": "boolean",+            "default": false+        },+        "maxLength": { "$ref": "#/definitions/positiveInteger" },+        "minLength": { "$ref": "#/definitions/positiveIntegerDefault0" },+        "pattern": {+            "type": "string",+            "format": "regex"+        },+        "additionalItems": {+            "anyOf": [+                { "type": "boolean" },+                { "$ref": "#" }+            ],+            "default": {}+        },+        "items": {+            "anyOf": [+                { "$ref": "#" },+                { "$ref": "#/definitions/schemaArray" }+            ],+            "default": {}+        },+        "maxItems": { "$ref": "#/definitions/positiveInteger" },+        "minItems": { "$ref": "#/definitions/positiveIntegerDefault0" },+        "uniqueItems": {+            "type": "boolean",+            "default": false+        },+        "maxProperties": { "$ref": "#/definitions/positiveInteger" },+        "minProperties": { "$ref": "#/definitions/positiveIntegerDefault0" },+        "required": { "$ref": "#/definitions/stringArray" },+        "additionalProperties": {+            "anyOf": [+                { "type": "boolean" },+                { "$ref": "#" }+            ],+            "default": {}+        },+        "definitions": {+            "type": "object",+            "additionalProperties": { "$ref": "#" },+            "default": {}+        },+        "properties": {+            "type": "object",+            "additionalProperties": { "$ref": "#" },+            "default": {}+        },+        "patternProperties": {+            "type": "object",+            "additionalProperties": { "$ref": "#" },+            "default": {}+        },+        "dependencies": {+            "type": "object",+            "additionalProperties": {+                "anyOf": [+                    { "$ref": "#" },+                    { "$ref": "#/definitions/stringArray" }+                ]+            }+        },+        "enum": {+            "type": "array",+            "minItems": 1,+            "uniqueItems": true+        },+        "type": {+            "anyOf": [+                { "$ref": "#/definitions/simpleTypes" },+                {+                    "type": "array",+                    "items": { "$ref": "#/definitions/simpleTypes" },+                    "minItems": 1,+                    "uniqueItems": true+                }+            ]+        },+        "allOf": { "$ref": "#/definitions/schemaArray" },+        "anyOf": { "$ref": "#/definitions/schemaArray" },+        "oneOf": { "$ref": "#/definitions/schemaArray" },+        "not": { "$ref": "#" }+    },+    "dependencies": {+        "exclusiveMaximum": [ "maximum" ],+        "exclusiveMinimum": [ "minimum" ]+    },+    "default": {}+}
+ test/Local.hs view
@@ -0,0 +1,54 @@++module Main where++import           Control.Applicative+import           Control.Monad          (unless)+import           Data.Aeson+import           Data.List              (isSuffixOf)+import           Data.Monoid+import           System.Directory       (getDirectoryContents)+import           Test.Tasty             (TestTree, defaultMain, testGroup)+import qualified Test.Tasty.HUnit       as HU+import           Test.Tasty.QuickCheck  (testProperty)++-- Examples+import qualified CustomSchema+import qualified Full+import qualified PrettyShowFailure+import qualified Simple++import           Data.JsonSchema.Draft4+import           Local.Failure          (correctPaths)+import           Local.Filesystem       (fetchFromFilesystem)+import           Local.Reference        (referenceTests)+import           Shared                 (isLocal, readSchemaTests, toTest)++dir :: String+dir = "JSON-Schema-Test-Suite/tests/draft4"++main :: IO ()+main = do+  filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir+  ts <- readSchemaTests dir filenames+  defaultMain . testGroup "Tests not requiring an HTTP server" $+      testGroup "Check that examples compile and don't throw errors" exampleTests+    : testGroup "QuickCheck tests" quickCheckTests+    : testGroup "Report the path to invalid data correctly" correctPaths+    : testGroup "Test the referencesViaFilesystem function" fetchFromFilesystem+    : testGroup "Test the Reference module" referenceTests+    : fmap toTest ts++quickCheckTests :: [TestTree]+quickCheckTests =+  [testProperty "Invert schemas through JSON without change" invertSchema]+  where+    invertSchema :: Schema -> Bool+    invertSchema a = Just a == decode (encode a)++exampleTests :: [TestTree]+exampleTests =+  [ HU.testCase "CustomSchema example" CustomSchema.example+  , HU.testCase "Full example" Full.example+  , HU.testCase "PrettyShowFailure example" PrettyShowFailure.example+  , HU.testCase "Simple example" Simple.example+  ]
+ test/Local/Failure.hs view
@@ -0,0 +1,55 @@++module Local.Failure where++import           Data.Aeson+import qualified Data.Aeson.Pointer     as P+import           Data.Monoid+import           Test.Tasty             (TestTree)+import qualified Test.Tasty.HUnit       as HU++import           Data.JsonSchema.Draft4+import qualified Data.Validator.Draft4  as VA++correctPaths :: [TestTree]+correctPaths =+  [ HU.testCase "Items object" itemsObject+  , HU.testCase "Items array" itemsArray+  ]++itemsObject :: IO ()+itemsObject = HU.assertEqual "Path to invalid data"+                             (P.Pointer [P.Token "0"])+                             (_invalidOffendingData failure)+  where+    [failure] = runValidate (ReferencedSchemas schema mempty)+                            sw (toJSON [[True, True]])++    schema :: Schema+    schema = emptySchema+      { _schemaItems = Just (VA.ItemsObject (emptySchema { _schemaUniqueItems = Just True }))+      }++    sw :: SchemaWithURI Schema+    sw = SchemaWithURI+      { _swSchema = schema+      , _swURI    = Nothing+      }++itemsArray :: IO ()+itemsArray = HU.assertEqual "Path to invalid data"+                            (P.Pointer [P.Token "0"])+                            (_invalidOffendingData failure)+  where+    [failure] = runValidate (ReferencedSchemas schema mempty)+                            sw (toJSON [[True, True]])++    schema :: Schema+    schema = emptySchema+      { _schemaItems = Just (VA.ItemsArray [emptySchema { _schemaUniqueItems = Just True }])+      }++    sw :: SchemaWithURI Schema+    sw = SchemaWithURI+      { _swSchema = schema+      , _swURI    = Nothing+      }
+ test/Local/Filesystem.hs view
@@ -0,0 +1,56 @@++module Local.Filesystem where++import           Control.Applicative+import           Data.Aeson+import           Data.Monoid+import           Test.Tasty             (TestTree)+import qualified Test.Tasty.HUnit       as HU+import           Data.Text              (Text)++import           Data.JsonSchema.Draft4++fetchFromFilesystem :: [TestTree]+fetchFromFilesystem =+  [ HU.testCase+      "readFile exceptions are turned into Lefts"+      readFileExceptions++  , HU.testCase+      "Relative reference to local file"+      (resolve "test/Local/schema.json")+  , HU.testCase+      "Chained relative references to local files"+      (resolve "./test/Local/schema-with-ref.json")+  ]++readFileExceptions :: IO ()+readFileExceptions = do+  res <- referencesViaFilesystem (SchemaWithURI schema Nothing)+  case res of+    Left (FSReadFailure _) -> pure ()+    a                      -> error (msg <> show a)+  where+    schema :: Schema+    schema = emptySchema { _schemaRef = Just "does-not-exist.json" }++    msg :: String+    msg = "expected referencesViaFilesystem to return ReadFailure,"+       <> " instead got: "++-- * Helpers++resolve :: Text -> IO ()+resolve ref = do+  let schema = emptySchema { _schemaRef = Just ref }+  res <- fetchFilesystemAndValidate (SchemaWithURI schema Nothing) badData+  case res of+    Left (FVData _) -> pure ()+    a               -> error (msg <> show a)+  where+    badData :: Value+    badData = toJSON [True, True]++    msg :: String+    msg = "expected fetchFilesystemAndValidate to return"+       <> " Left (FVData [_]), instead got: "
+ test/Local/Reference.hs view
@@ -0,0 +1,51 @@++module Local.Reference where++import           Test.Tasty               (TestTree)+import qualified Test.Tasty.HUnit         as HU++import           Data.Validator.Reference++referenceTests :: [TestTree]+referenceTests =+  [ HU.testCase "updateResolutionScope test cases" updateResolutionScopeTests+  , HU.testCase "resolveReference test cases" resolveReferenceTests+  ]++updateResolutionScopeTests :: IO ()+updateResolutionScopeTests = do+  HU.assertEqual+    "case 1 result"+    Nothing+    (updateResolutionScope Nothing Nothing)+  HU.assertEqual+    "case 2 result"+    Nothing+    (updateResolutionScope Nothing (Just "#"))+  HU.assertEqual+    "case 3 result"+    (Just "foo")+    (updateResolutionScope Nothing (Just "foo"))+  HU.assertEqual+    "case 4 result"+    (Just "/./bar") -- TODO: Normalize after updateResolutionScope.+    (updateResolutionScope (Just "/foo") (Just "./bar"))++resolveReferenceTests :: IO ()+resolveReferenceTests = do+  HU.assertEqual+    "case 1 result"+    (Just "/bar", Nothing)+    (resolveReference (Just "/foo") "bar")+  HU.assertEqual+    "case 2 result"+    (Just "/baz", Nothing)+    (resolveReference (Just "/foo/bar") "/baz")+  HU.assertEqual+    "case 3 result"+    (Nothing, Just "/bar")+    (resolveReference Nothing "#/bar")+  HU.assertEqual+    "case 4 result"+    (Just "/foo", Just "/bar")+    (resolveReference (Just "/foo") "#/bar")
+ test/Local/schema-with-ref.json view
@@ -0,0 +1,3 @@+{+  "$ref": "./schema.json"+}
+ test/Local/schema.json view
@@ -0,0 +1,3 @@+{+  "uniqueItems": true+}
+ test/Remote.hs view
@@ -0,0 +1,26 @@+module Main where++import           Control.Applicative+import           Control.Concurrent.Async       (withAsync)+import           Data.List                      (isSuffixOf)+import           Network.Wai.Application.Static (defaultFileServerSettings,+                                                 staticApp)+import           Network.Wai.Handler.Warp       (run)+import           System.Directory               (getDirectoryContents)+import           Test.Tasty                     (defaultMain, testGroup)++import           Shared                         (isLocal, readSchemaTests,+                                                 toTest)++dir :: String+dir = "JSON-Schema-Test-Suite/tests/draft4"++main :: IO ()+main = withAsync serve $ \_ -> do+  filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)+                 <$> getDirectoryContents dir+  ts <- readSchemaTests dir filenames+  defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts++serve :: IO ()+serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes"
+ test/Shared.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveGeneric #-}++module Shared 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           Data.Monoid+import           Data.Text              (Text)+import qualified Data.Text              as T+import           GHC.Generics+import           System.FilePath        ((</>))+import           Test.Tasty             (TestTree)+import qualified Test.Tasty.HUnit       as HU++import qualified Data.JsonSchema.Draft4 as D4++isLocal :: String -> Bool+isLocal file = (file /= "definitions.json")+            && (file /= "ref.json")+            && (file /= "refRemote.json")++data SchemaTest = SchemaTest+  { _stDescription :: Text+  , _stSchema      :: D4.Schema+  , _stCases       :: [SchemaTestCase]+  }++data SchemaTestCase = SchemaTestCase+  { _scDescription :: Text+  , _scData        :: Value+  , _scValid       :: Bool+  } deriving Generic++instance FromJSON SchemaTest where+  parseJSON = withObject "SchemaTest" $ \o -> SchemaTest+    <$> o .: "description"+    <*> o .: "schema"+    <*> o .: "tests" -- Perhaps "cases" would have been a more descriptive key.++instance FromJSON SchemaTestCase where+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = fmap toLower . drop 3 }++readSchemaTests :: String -> [String] -> IO [SchemaTest]+readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles+  where+    -- Each file contains an array of SchemaTests, not just one.+    fileToCases :: String -> IO [SchemaTest]+    fileToCases name = do+      let fullPath = dir </> name+      jsonBS <- LBS.readFile fullPath+      case eitherDecode jsonBS of+        Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e+        Right schemaTests -> pure $ prependFileName name <$> schemaTests++    prependFileName :: String -> SchemaTest -> SchemaTest+    prependFileName fileName s = s+      { _stDescription = T.pack fileName <> ": " <> _stDescription s+      }++    concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+    concatMapM f xs = liftM concat (mapM f xs)++toTest :: SchemaTest -> TestTree+toTest st =+  HU.testCase (T.unpack (_stDescription st)) $ do+    forM_ (_stCases st) $ \sc -> do+      g <- assertRight =<< D4.referencesViaHTTP (D4.SchemaWithURI (_stSchema st) Nothing)+      validate <- assertRight . D4.checkSchema g $ D4.SchemaWithURI (_stSchema st) Nothing+      let res = validate (_scData sc)+      if _scValid sc+        then assertValid   sc res+        else assertInvalid sc res++assertValid :: SchemaTestCase -> [D4.Invalid] -> HU.Assertion+assertValid _ [] = pure ()+assertValid sc errs =+  HU.assertFailure $ unlines+    [ "    Failed to validate data"+    , "    Description: "         <> T.unpack (_scDescription sc)+    , "    Data: "                <> show (_scData sc)+    , "    Validation failures: " <> show errs+    ]++assertInvalid :: SchemaTestCase -> [D4.Invalid] -> HU.Assertion+assertInvalid sc [] =+  HU.assertFailure $ unlines+    [ "    Validated invalid data"+    , "    Description: " <> T.unpack (_scDescription sc)+    , "    Data: "        <> show (_scData sc)+    ]+assertInvalid _ _ = pure ()++assertRight :: (Show a) => Either a b -> IO b+assertRight (Left e)  = HU.assertFailure (show e) >> fail "assertRight failed"+assertRight (Right b) = pure b
− tests/Local.hs 
@@ -1,76 +0,0 @@--module Main where--import           Control.Applicative-import           Control.Monad          (unless)-import           Data.Aeson-import qualified Data.Aeson.Pointer     as P-import           Data.List              (isSuffixOf)-import           Data.Monoid-import           System.Directory       (getDirectoryContents)-import           Test.Tasty             (TestTree, defaultMain, testGroup)-import qualified Test.Tasty.HUnit       as HU-import           Test.Tasty.QuickCheck  (testProperty)--import           Data.JsonSchema.Draft4 (Failure(..), Schema(..),-                                         SchemaCache(..), SchemaContext(..),-                                         emptySchema, runValidate)-import qualified Data.Validator.Draft4  as VA-import           Shared                 (isLocal, readSchemaTests, toTest)--dir :: String-dir = "JSON-Schema-Test-Suite/tests/draft4"--main :: IO ()-main = do-  filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir-  ts <- readSchemaTests dir filenames-  defaultMain . testGroup "Tests not requiring an HTTP server" $-      testProperty "Invert schemas through JSON without change" invertSchema-    : testGroup "Make paths to invalid data correctly" correctPaths-    : fmap toTest ts--invertSchema :: Schema -> Bool-invertSchema a = Just a == decode (encode a)--correctPaths :: [TestTree]-correctPaths =-  [ HU.testCase "Items object" itemsObject-  , HU.testCase "Items array" itemsArray-  ]--itemsObject :: IO ()-itemsObject = HU.assertEqual "Path to invalid data"-                             (P.Pointer [P.Token "0"])-                             (_failureOffendingData failure)-  where-    [failure] = runValidate (SchemaCache schema mempty) sc (toJSON [[True, True]])--    schema :: Schema-    schema = emptySchema-      { _schemaItems = Just (VA.ItemsObject (emptySchema { _schemaUniqueItems = Just True }))-      }--    sc :: SchemaContext Schema-    sc = SchemaContext-      { _scURI    = Nothing-      , _scSchema = schema-      }--itemsArray :: IO ()-itemsArray = HU.assertEqual "Path to invalid data"-                            (P.Pointer [P.Token "0"])-                            (_failureOffendingData failure)-  where-    [failure] = runValidate (SchemaCache schema mempty) sc (toJSON [[True, True]])--    schema :: Schema-    schema = emptySchema-      { _schemaItems = Just (VA.ItemsArray [emptySchema { _schemaUniqueItems = Just True }])-      }--    sc :: SchemaContext Schema-    sc = SchemaContext-      { _scURI    = Nothing-      , _scSchema = schema-      }
− tests/Remote.hs 
@@ -1,26 +0,0 @@-module Main where--import           Control.Applicative-import           Control.Concurrent.Async       (withAsync)-import           Data.List                      (isSuffixOf)-import           Network.Wai.Application.Static (defaultFileServerSettings,-                                                 staticApp)-import           Network.Wai.Handler.Warp       (run)-import           System.Directory               (getDirectoryContents)-import           Test.Tasty                     (defaultMain, testGroup)--import           Shared                         (isLocal, readSchemaTests,-                                                 toTest)--dir :: String-dir = "JSON-Schema-Test-Suite/tests/draft4"--main :: IO ()-main = withAsync serve $ \_ -> do-  filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)-                 <$> getDirectoryContents dir-  ts <- readSchemaTests dir filenames-  defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts--serve :: IO ()-serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes"
− tests/Shared.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Shared 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           Data.Monoid-import           Data.Text              (Text)-import qualified Data.Text              as T-import           GHC.Generics-import           System.FilePath        ((</>))-import           Test.Tasty             (TestTree)-import qualified Test.Tasty.HUnit       as HU--import qualified Data.JsonSchema.Draft4 as D4--isLocal :: String -> Bool-isLocal file = (file /= "definitions.json")-            && (file /= "ref.json")-            && (file /= "refRemote.json")--data SchemaTest = SchemaTest-  { _stDescription :: Text-  , _stSchema      :: D4.Schema-  , _stCases       :: [SchemaTestCase]-  }--data SchemaTestCase = SchemaTestCase-  { _scDescription :: Text-  , _scData        :: Value-  , _scValid       :: Bool-  } deriving Generic--instance FromJSON SchemaTest where-  parseJSON = withObject "SchemaTest" $ \o -> SchemaTest-    <$> o .: "description"-    <*> o .: "schema"-    <*> o .: "tests" -- Perhaps "cases" would have been a more descriptive key.--instance FromJSON SchemaTestCase where-  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = fmap toLower . drop 3 }--readSchemaTests :: String -> [String] -> IO [SchemaTest]-readSchemaTests dir jsonFiles = concatMapM fileToCases jsonFiles-  where-    -- Each file contains an array of SchemaTests, not just one.-    fileToCases :: String -> IO [SchemaTest]-    fileToCases name = do-      let fullPath = dir </> name-      jsonBS <- LBS.readFile fullPath-      case eitherDecode jsonBS of-        Left e -> fail $ "couldn't parse file '" <> fullPath <> "': " <> e-        Right schemaTests -> pure $ prependFileName name <$> schemaTests--    prependFileName :: String -> SchemaTest -> SchemaTest-    prependFileName fileName s = s-      { _stDescription = T.pack fileName <> ": " <> _stDescription s-      }--    concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]-    concatMapM f xs = liftM concat (mapM f xs)--toTest :: SchemaTest -> TestTree-toTest st =-  HU.testCase (T.unpack (_stDescription st)) $ do-    forM_ (_stCases st) $ \sc -> do-      g <- assertRight =<< D4.fetchReferencedSchemas mempty (D4.SchemaContext Nothing (_stSchema st))-      validate <- assertRight . D4.checkSchema g $ D4.SchemaContext Nothing (_stSchema st)-      let res = validate (_scData sc)-      if _scValid sc-        then assertValid   sc res-        else assertInvalid sc res--assertValid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion-assertValid _ [] = pure ()-assertValid sc errs =-  HU.assertFailure $ unlines-    [ "    Failed to validate data"-    , "    Description: "         <> T.unpack (_scDescription sc)-    , "    Data: "                <> show (_scData sc)-    , "    Validation failures: " <> show errs-    ]--assertInvalid :: SchemaTestCase -> [D4.Failure] -> HU.Assertion-assertInvalid sc [] =-  HU.assertFailure $ unlines-    [ "    Validated invalid data"-    , "    Description: " <> T.unpack (_scDescription sc)-    , "    Data: "        <> show (_scData sc)-    ]-assertInvalid _ _ = pure ()--assertRight :: (Show a) => Either a b -> IO b-assertRight (Left e)  = HU.assertFailure (show e) >> fail "assertRight failed"-assertRight (Right b) = pure b