hjsonschema 0.8.0.1 → 0.9.0.0

raw patch · 38 files changed

+2301/−1395 lines, 38 filesdep +QuickCheckdep +semigroupsdep +tastydep −hashabledep −mtldep −test-frameworkdep ~aesondep ~basedep ~hjsonpointerPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, semigroups, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: hashable, mtl, test-framework, test-framework-hunit, transformers

Dependency ranges changed: aeson, base, hjsonpointer, unordered-containers

API changes (from Hackage documentation)

Files

• Example.hs +0/−103
• README.md +2/−2
• changelog.txt +7/−0
• examples/CustomSchema.hs +66/−0
• examples/Main.hs +19/−0
• examples/PrettyShowFailure.hs +47/−0
• examples/Standard.hs +52/−0
• hjsonschema.cabal +54/−42
• src/Data/JsonSchema.hs +0/−86
• src/Data/JsonSchema/Core.hs +0/−91
• src/Data/JsonSchema/Draft4.hs +59/−131
• src/Data/JsonSchema/Draft4/Any.hs +0/−115
• src/Data/JsonSchema/Draft4/Arrays.hs +0/−100
• src/Data/JsonSchema/Draft4/Failure.hs +68/−0
• src/Data/JsonSchema/Draft4/Internal.hs +280/−0
• src/Data/JsonSchema/Draft4/Numbers.hs +0/−61
• src/Data/JsonSchema/Draft4/Objects.hs +0/−118
• src/Data/JsonSchema/Draft4/Objects/Properties.hs +0/−145
• src/Data/JsonSchema/Draft4/Schema.hs +334/−0
• src/Data/JsonSchema/Draft4/Strings.hs +0/−44
• src/Data/JsonSchema/Fetch.hs +133/−0
• src/Data/JsonSchema/Helpers.hs +0/−160
• src/Data/JsonSchema/Reference.hs +0/−65
• src/Data/Validator/Draft4.hs +8/−0
• src/Data/Validator/Draft4/Any.hs +179/−0
• src/Data/Validator/Draft4/Array.hs +168/−0
• src/Data/Validator/Draft4/Number.hs +51/−0
• src/Data/Validator/Draft4/Object.hs +147/−0
• src/Data/Validator/Draft4/Object/Properties.hs +187/−0
• src/Data/Validator/Draft4/String.hs +29/−0
• src/Data/Validator/Failure.hs +42/−0
• src/Data/Validator/Reference.hs +67/−0
• src/Data/Validator/Utils.hs +122/−0
• src/Import.hs +1/−0
• tests/Lib.hs +0/−113
• tests/Local.hs +67/−9
• tests/Remote.hs +13/−10
• tests/Shared.hs +99/−0

@@ -1,103 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import           Control.Applicative-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 is designed to be imported unqualified.--- We're just being explicit here for example purposes.--main :: IO ()-main = do-  simpleExample-  fullExample------------------------------------------------------- * Example Schema and Data-----------------------------------------------------schemaData :: JS.RawSchema-schemaData = JS.RawSchema-  { JS._rsURI  = Nothing-  -- ^ If your schema has relative references to other schemas-  -- then you'll need to include this.-  , JS._rsData = schemaJSON-  }-  where-    schemaJSON :: HashMap Text Value-    schemaJSON = H.singleton "uniqueItems" (Bool True)--badData :: Value-badData = Array $ V.fromList ["foo", "foo"]------------------------------------------------------- * Simple Example------------------------------------------------------- | Since our schema contains no references to other schemas,--- we can skip the fetchGraph step.-simpleExample :: IO ()-simpleExample = do-  schema <- compileSchema (JS.SchemaGraph schemaData H.empty) schemaData-  checkResults (JS.validate schema badData)------------------------------------------------------- * Full Example------------------------------------------------------- | For a schema that might contain references to other schemas.-fullExample :: IO ()-fullExample = do-  let currentSchemaCache = H.empty-  schemaGraph <- fetchGraph currentSchemaCache schemaData--  -- We aren't going to use it for anything this time, but if we were caching-  -- remote schemas this would be our new cache.-  ---  -- let newSchemaCache = _cachedSchemas schemaData <> currentSchemaGraph--  schema <- compileSchema schemaGraph schemaData-  checkResults (JS.validate schema badData)--  where-    fetchGraph :: HashMap Text (HashMap Text Value) -> JS.RawSchema -> IO JS.SchemaGraph-    fetchGraph graph rs = do-      eitherGraph <- JS.fetchReferencedSchemas JS.draft4 graph rs-      case eitherGraph of-        Left e  -> error $ "Failed to fetch graph with error: " <> T.unpack e-        Right g -> return g------------------------------------------------------- * Helper Functions-----------------------------------------------------compileSchema :: JS.SchemaGraph -> 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

@@ -4,11 +4,11 @@  [Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) -NOTE: You currently CANNOT use untrusted JSON data to make schemas. Schemas with circular references can cause infinite loops. This is being addressed: see the issue list.+NOTE: You CANNOT use untrusted JSON data to make schemas. Schemas with circular references can cause infinite loops. See the issue list for more info.  # Example -See [Example.hs on GitHub](https://github.com/seagreen/hjsonschema/blob/master/Example.hs).+See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Example.hs).  # Tests 

@@ -1,3 +1,10 @@+# 0.9+++ Partial rewrite. The API of the library has changed, see the examples+folder for how to use the new one.+++ Users of the library can now write schemas in Haskell as well as JSON.+ # 0.8  + Improve scope updating and resolving.

@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++-- | A custom schema made up of 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'.++module CustomSchema where++import           Data.Aeson+import           Data.Maybe             (maybeToList)+import           Data.Text              (Text)+import qualified Data.Text              as T++import qualified Data.Validator.Draft4  as VA+import qualified Data.Validator.Failure as FR++-- | Our custom validator.+oddLength :: Bool -> Text -> Maybe (FR.Failure () )+oddLength b t+  | b == odd (T.length t) = Nothing+  | otherwise             = Just (FR.Failure () (Bool b) mempty)++data CustomError+  = MaxLength+  | OddLength++-- If we were really using the schema we would also need ToJSON and FromJSON+-- instances.+data Schema = Schema+  { _schemaMaxLength :: Maybe Int+  , _schemaOddLength :: Maybe Bool+  }++-- | Since every 'Schema' is valid we don't need to bother defining something+-- like 'Data.JsonSchema.Draft4.checkValidity' for this schema.+validate :: Schema -> Value -> [FR.Failure CustomError]+validate s (String x) = concat+  [ f _schemaMaxLength (FR.setFailure MaxLength) (fmap maybeToList . VA.maxLength)+  , f _schemaOddLength (FR.setFailure OddLength) (fmap maybeToList . oddLength)+  ]+  where+    -- This pattern is overkill here, but is helpful if you have lots of+    -- validators (e.g. the Draft 4 schema has 27).+    f :: (Schema -> Maybe val)+      -> (err -> FR.Failure CustomError)+      -> (val -> Text -> [err])+      -> [FR.Failure CustomError]+    f field modifyError runVal =+      maybe mempty (\val -> modifyError <$> runVal val x) (field s)+validate _ _ = mempty -- Our schema passes everything that isn't a string.++example :: IO ()+example =+  case validate schema badData of+    [] -> error "We validated bad data."+    [FR.Failure OddLength _ _] -> putStrLn "Success."+    _ -> error "We got a different failure than expected."+  where+    schema :: Schema+    schema = Schema (Just 100) (Just True)++    badData :: Value+    badData = String "even"

@@ -0,0 +1,19 @@++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

@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module PrettyShowFailure where++import           Data.Aeson+import qualified Data.Aeson.Pointer     as AP+import           Data.Monoid++import qualified Data.JsonSchema.Draft4 as D4++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"]+  }++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+    Left _  -> error "Couldn't resolve pointer."+    Right v -> v++example :: IO ()+example = putStrLn . unlines $+  [ "Invalid data. Here's the sequence of validators that caught it:"+  , ""+  , "  " <> show (D4._failureValidatorsCalled failure)+  , ""+  , "Here's the contents of the final validator in that sequence:"+  , ""+  , "  " <> show (D4._failureFinalValidator failure)+  , ""+  , "Here's a JSON Pointer to the invalid part of the data:"+  , ""+  , "  " <> show (D4._failureOffendingData failure)+  , ""+  , "Here's the invalid part of the data:"+  , ""+  , "  " <> show subsetOfData+  ]

@@ -0,0 +1,52 @@+{-# 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

@@ -1,5 +1,5 @@ name:                   hjsonschema-version:                0.8.0.1+version:                0.9.0.0 synopsis:               JSON Schema library homepage:               https://github.com/seagreen/hjsonschema license:                MIT@@ -14,73 +14,80 @@                         draft4.json                         JSON-Schema-Test-Suite/tests/draft4/*.json                         README.md-                        tests/Lib.hs+                        tests/Shared.hs  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-  other-modules:        Data.JsonSchema.Core-                        Data.JsonSchema.Draft4-                      , Data.JsonSchema.Draft4.Objects.Properties+  exposed-modules:      Data.JsonSchema.Draft4+                      , Data.JsonSchema.Draft4.Internal+                      , Data.JsonSchema.Fetch+                      , Data.Validator.Draft4+                      , Data.Validator.Failure+                      , Data.Validator.Reference+                      , Data.Validator.Utils++  other-modules:        Data.JsonSchema.Draft4.Failure+                      , Data.JsonSchema.Draft4.Schema+                      , Data.Validator.Draft4.Any+                      , Data.Validator.Draft4.Array+                      , Data.Validator.Draft4.Number+                      , Data.Validator.Draft4.Object+                      , Data.Validator.Draft4.Object.Properties+                      , Data.Validator.Draft4.String                       , Import   default-language:     Haskell2010   default-extensions:   ScopedTypeVariables                         OverloadedStrings-  other-extensions:     TemplateHaskell   ghc-options:          -Wall-  build-depends:        aeson                >= 0.7   && < 0.11+  build-depends:        aeson                >= 0.7    && < 0.12                         -- 4.6 doesn't have a Traversable Either instance:-                      , base                 >= 4.7   && < 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.10-                      , 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+                      , base                 >= 4.7    && < 4.9+                      , bytestring           >= 0.10   && < 0.11+                      , containers           >= 0.5    && < 0.6+                      , file-embed           >= 0.0.8  && < 0.0.10+                      , hjsonpointer         >= 0.3    && < 0.4+                      , http-client          >= 0.4.9  && < 0.5+                      , http-types           >= 0.8    && < 0.10+                      , QuickCheck           >= 2.8.1  && < 2.9+                      , regexpr              >= 0.5    && < 0.6+                      , scientific           >= 0.3    && < 0.4+                      , semigroups           >= 0.18.0 && < 0.19+                      , unordered-containers >= 0.2    && < 0.3+                      , text                 >= 1.2    && < 1.3+                      , vector               >= 0.10   && < 0.12  test-suite local   type:                 exitcode-stdio-1.0   hs-source-dirs:       tests   main-is:              Local.hs+  other-modules:        Shared   default-language:     Haskell2010-  ghc-options:          -Wall+  ghc-options:          -Wall -fno-warn-orphans   default-extensions:   OverloadedStrings-  other-extensions:     TemplateHaskell   build-depends:        aeson                       , base                       , bytestring+                      , hjsonpointer                       , hjsonschema                       , text+                      , QuickCheck+                      , unordered-containers                       , vector-                      , directory            >= 1.2 && < 1.3-                      , filepath             >= 1.3 && < 1.5-                      , HUnit                >= 1.2 && < 1.4-                      , test-framework       >= 0.8 && < 0.9-                      , test-framework-hunit >= 0.3 && < 0.4+                      , 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+                      , tasty-quickcheck     >= 0.8  && < 0.9  test-suite remote   type:                 exitcode-stdio-1.0   hs-source-dirs:       tests   main-is:              Remote.hs+  other-modules:        Shared   default-language:     Haskell2010-  ghc-options:          -Wall+  ghc-options:          -Wall -fno-warn-orphans   default-extensions:   OverloadedStrings-  other-extensions:     TemplateHaskell   build-depends:        aeson                       , async                       , base@@ -91,17 +98,22 @@                       , directory                       , filepath                       , HUnit-                      , test-framework-                      , test-framework-hunit+                      , tasty+                      , tasty-hunit                       , wai-app-static                       , warp  executable example-  main-is:              Example.hs+  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

@@ -1,86 +0,0 @@-{-# 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.Monad.Except (MonadError, MonadIO, join, throwError)-import qualified Data.ByteString.Lazy as LBS-import           Data.Foldable-import qualified Data.HashMap.Strict as H-import           Data.String--import           Data.JsonSchema.Core-import           Data.JsonSchema.Draft4-import qualified Data.JsonSchema.Helpers as HE-import           Data.JsonSchema.Reference-import           Import---- For GHCs before 7.10:-import           Prelude hiding (concat, sequence)---- | Take a schema. Retrieve every document either it or its--- subschemas include via the "$ref" keyword. Load a 'SchemaGraph' out--- with them.-fetchReferencedSchemas :: Spec err -> SchemaCache -> RawSchema -> IO (Either Text SchemaGraph)-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 URIs.-fetchReferencedSchemas'-  -- The `Functor m` declaration is for GHCs before 7.10.-  :: forall m e t err. (MonadIO m, Functor m, MonadError t e, Traversable e, IsString t)-  => (Text -> m (e LBS.ByteString))-  -> Spec err-  -> SchemaCache-  -> RawSchema-  -> m (e SchemaGraph)-fetchReferencedSchemas' fetchRef spec cache rawSchema = do-  let startingCache = case _rsURI rawSchema of-                        Nothing  -> cache-                        Just uri -> H.insert uri (_rsData rawSchema) cache-  fmap (SchemaGraph rawSchema) <$> foldlM fetch (return startingCache) (includeSubschemas rawSchema)--  where-    -- TODO: use a fold here-    includeSubschemas :: RawSchema -> [RawSchema]-    includeSubschemas r =-      let scope = _rsURI r `newResolutionScope` _rsData r-          xs = H.intersectionWith (\(ValSpec f _) x -> f scope x) (_unSpec spec) (_rsData r)-      in r : (concat . concat . H.elems $ fmap includeSubschemas <$> xs)--    fetch :: e SchemaCache -> RawSchema -> m (e SchemaCache)-    fetch eg r = join <$> sequence (run <$> eg)-      where-        run :: SchemaCache -> m (e SchemaCache)-        run g = 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 (_rsURI r) (_rsData r)-          case resolveReference scope <$> (H.lookup "$ref" (_rsData r) >>= HE.toTxt) of-            Just (Just uri,_) ->-              if not (isRemoteReference uri) || H.member uri g-                then return (return g)-                else fetchRef uri >>= decodeResponse g uri-            _ -> return (return g)--        decodeResponse :: SchemaCache -> Text -> e LBS.ByteString -> m (e SchemaCache)-        decodeResponse g uri eBts = join <$> sequence (runDecode g uri <$> eBts)--        runDecode :: SchemaCache -> Text -> LBS.ByteString -> m (e SchemaCache)-        runDecode g uri bts =-          case eitherDecode bts of-            Left e    -> return $ throwError (fromString e)-            Right obj -> fmap _cachedSchemas <$> fetchReferencedSchemas' fetchRef spec g (RawSchema (Just uri) obj)

@@ -1,91 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Data.JsonSchema.Core where--import qualified Data.HashMap.Strict       as H-import           Data.Maybe--import           Data.JsonSchema.Reference-import           Import---- For GHCs before 7.10:-import           Prelude                   hiding (concat, sequence)------------------------------------------------------- * Primary API-----------------------------------------------------compile :: forall err. Spec err -> SchemaGraph -> 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 :: ValSpec err -> Value -> Maybe (Value -> [ValidationFailure err])-    f (ValSpec _ construct) valJSON = construct spec g (RawSchema (newResolutionScope t o) o) valJSON--validate :: Schema err -> Value -> [ValidationFailure err]-validate schema x = concat . fmap ($ x) . _unSchema $ schema------------------------------------------------------- * Schemas-----------------------------------------------------newtype Spec err = Spec { _unSpec :: HashMap Text (ValSpec err) }--newtype Schema err = Schema { _unSchema :: [Value -> [ValidationFailure err]] }--data RawSchema = RawSchema-  { _rsURI  :: !(Maybe Text)-  -- ^ NOTE: Must not include a URI fragment.-  , _rsData :: !(HashMap Text Value)-  } deriving (Show)---- | A set of RawSchemas, split into a HashMap.------ Keys correspond to Schema _rsURIs. Values correspond to Schema _rsDatas.-type SchemaCache = HashMap Text (HashMap Text Value)--data SchemaGraph = SchemaGraph-  { _startingSchema :: !RawSchema-  -- ^ The schema initially referenced by '#'.-  , _cachedSchemas  :: !SchemaCache-  } deriving (Show)------------------------------------------------------- * Validators-----------------------------------------------------data ValSpec err = ValSpec EmbeddedSchemas (ValidatorConstructor err [ValidationFailure err])---- | Return a schema's immediate subschemas.------ This is used by 'Data.JsonSchema.fetchRefs' to find all the--- subschemas in a document. This allows it to process only--- "$ref"s and "id"s that are actual schema keywords.-type EmbeddedSchemas = Maybe Text -> Value -> [RawSchema]---- | 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-  -> SchemaGraph-  -> RawSchema-  -> Value-  -> Maybe (Value -> valErr)--data ValidationFailure err = ValidationFailure-  { _failureName :: !err-  , _failureInfo :: !FailureInfo-  } deriving (Show)--data FailureInfo = FailureInfo-  { _validatingData :: !Value-  , _offendingData  :: !Value-  } deriving (Show)

@@ -1,142 +1,70 @@-{-# 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+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-} -  | Maximum-  | ExclusiveMaximum+module Data.JsonSchema.Draft4+  ( Schema(..)+  , emptySchema+  , checkSchema -  | Minimum-  | ExclusiveMinimum+    -- * Fetching tools+  , SchemaContext(..)+  , SchemaCache(..)+  , fetchReferencedSchemas -  | MaxLength-  | MinLength-  | Pattern+    -- * Failure+  , Failure(..)+  , ValidatorChain(..) -  | Items Draft4Failure-  | AdditionalItemsBool-  | AdditionalItemsObject Draft4Failure+    -- * Other Draft 4 things exported just in case+  , schemaValidity+  , IN.runValidate+  ) where -  | MaxItems-  | MinItems-  | UniqueItems-  | MaxProperties-  | MinProperties-  | Required+import           Data.Aeson+import qualified Data.ByteString.Lazy            as LBS+import           Data.FileEmbed+import qualified Data.HashMap.Strict             as H+import           Data.Maybe                      (fromMaybe) -  | Properties Draft4Failure-  | PatternProperties Draft4Failure-  | AdditionalPropertiesBool-  | AdditionalPropertiesObject Draft4Failure+import           Data.JsonSchema.Draft4.Failure+import qualified Data.JsonSchema.Draft4.Internal as IN+import           Data.JsonSchema.Draft4.Schema+import           Data.JsonSchema.Fetch           (SchemaCache(..),+                                                  SchemaContext(..),+                                                  URISchemaMap)+import qualified Data.JsonSchema.Fetch           as FE+import           Data.Validator.Reference        (baseAndFragment)+import           Import -  | SchemaDependency Draft4Failure-  | PropertyDependency+-- | Check the validity of a schema and 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 -  | Enum-  | TypeValidator-  | AllOf Draft4Failure-  | AnyOf-  | OneOf-  | NotValidator-  | Ref Draft4Failure-  deriving (Eq, Show, Read)+fetchReferencedSchemas+  :: URISchemaMap Schema+  -> SchemaContext Schema+  -> IO (Either Text (SchemaCache Schema))+fetchReferencedSchemas =+  FE.fetchReferencedSchemas IN.embedded _schemaId _schemaRef -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.-  ]+-- | 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   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  ->-      let a = RawSchema Nothing s-      in validate (compile draft4 (SchemaGraph a mempty) a) $ Object (_rsData r)+    d4 :: Schema+    d4 = fromMaybe (error "Schema decode failed (this should never happen)")+       . decode . LBS.fromStrict $ $(embedFile "draft4.json") --- | 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 :: SchemaGraph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure)-compileDraft4 g r =-  case isValidSchema r of-    []   -> Right (compile draft4 g r)-    errs -> Left errs+    -- @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

@@ -1,115 +0,0 @@--module Data.JsonSchema.Draft4.Any where--import           Control.Monad-import qualified Data.HashMap.Strict       as H-import           Data.Maybe-import           Data.Scientific-import qualified Data.Vector               as V--import           Data.JsonSchema.Core-import           Data.JsonSchema.Helpers-import           Data.JsonSchema.Reference-import           Import---- For GHCs before 7.10:-import           Prelude                   hiding (any)---- | 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 subSchema = compile spec g $ RawSchema (_rsURI s) o-  Just $ \x ->-    case validate subSchema x of-      [] -> pure (FailureInfo val x)-      _  -> mempty-notValidator _ _ _ _ = Nothing---- JSON Reference Draft Document:------      http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03-ref :: ValidatorConstructor err [ValidationFailure err]-ref spec g s (String val) = do-  let (mUri, mFragment) = resolveReference (_rsURI s) val-  r <- RawSchema mUri <$> getReference mUri-  let o = resolveFragment mFragment (_rsData r)-  return . validate . compile spec g $ RawSchema (_rsURI r) o-  where-    getReference :: Maybe Text -> Maybe (HashMap Text Value)-    getReference Nothing  = Just . _rsData . _startingSchema $ g-    getReference (Just t) = H.lookup t (_cachedSchemas g)--ref _ _ _ _ = Nothing

@@ -1,100 +0,0 @@--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--data AdditionalItemsFailure err-  = AdditionalBool-  | AdditionalObject 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" (_rsData 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 <> fmap (modifyFailureName f) additionalItemFailures-      _ -> mempty-  where-    f :: AdditionalItemsFailure err -> ItemsFailure err-    f AdditionalBool         = AdditionalItemsBool-    f (AdditionalObject err) = AdditionalItemsObject err-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 :: ValidatorConstructor err [ValidationFailure (AdditionalItemsFailure err)]-additionalItems _ _ _ val@(Bool v) =-  Just $ \x ->-    case x of-      Array ys ->-        if not v && V.length ys > 0-          then pure $ ValidationFailure AdditionalBool (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 AdditionalObject) . 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,68 @@++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++data ValidatorChain+  = MultipleOf+  | Maximum+  | ExclusiveMaximum+  | Minimum+  | ExclusiveMinimum++  | MaxLength+  | MinLength+  | PatternValidator++  | MaxItems+  | MinItems+  | UniqueItems+  | Items ValidatorChain+  | AdditionalItemsBool+  | AdditionalItemsObject ValidatorChain++  | MaxProperties+  | MinProperties+  | Required+  | SchemaDependency ValidatorChain+  | PropertyDependency+  | Properties ValidatorChain+  | PatternProperties ValidatorChain+  | AdditionalPropertiesBool+  | AdditionalPropertiesObject ValidatorChain++  | RefResolution+    -- ^ Indicates a reference that failed to resolve.+    --+    -- NOTE: The language agnostic test suite doesn't specify if this should+    -- cause a validation error or should allow data to pass. We choose to+    -- return a validation error.+    --+    -- Also note that ideally we would enforce in the type system that any+    -- failing references be dealt with before valididation. Then this could+    -- be removed entirely.+  | Ref ValidatorChain+  | Enum+  | TypeValidator+  | AllOf ValidatorChain+  | AnyOf+  | OneOf+  | NotValidator+  deriving (Eq, Show)

@@ -0,0 +1,280 @@++module Data.JsonSchema.Draft4.Internal where++import           Data.Aeson+import qualified Data.HashMap.Strict            as H+import qualified Data.List.NonEmpty             as N+import           Data.Maybe                     (catMaybes, fromMaybe, isJust,+                                                 maybeToList)+import           Data.Scientific++import           Data.JsonSchema.Draft4.Failure+import           Data.JsonSchema.Draft4.Schema+import           Data.JsonSchema.Fetch          (SchemaCache(..),+                                                 SchemaContext(..))+import qualified Data.Validator.Draft4.Any      as AN+import qualified Data.Validator.Draft4.Array    as AR+import qualified Data.Validator.Draft4.Number   as NU+import qualified Data.Validator.Draft4.Object   as OB+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           Import++-- For GHCs before 7.10:+import           Prelude                        hiding (concat)++--------------------------------------------------+-- * Embedded Schemas+--------------------------------------------------++-- | Return a schema's immediate subschemas.+--+-- Pass this to 'fetchReferencedSchemas' so that function can find all the+-- subschemas in a document. This allows 'fetchReferencedSchemas' to process+-- only "$ref"s and "id"s that are actual schema keywords. For example,+-- within a "properties" validator object an "id" key doesn't actually change+-- any scope, but instead serves a validator-specific function.+embedded :: Schema -> [Schema]+embedded schema = concat+  [ f _schemaItems+      (\x -> case x of+               AR.ItemsObject s -> pure s+               AR.ItemsArray ss -> ss+      )+  , f _schemaAdditionalItems+      (\x -> case x of+               AR.AdditionalObject s -> pure s+               _                     -> mempty+      )+  , f _schemaDependencies (catMaybes . fmap checkDependency . H.elems)+  , f _schemaProperties H.elems+  , f _schemaPatternProperties H.elems+  , f _schemaAdditionalProperties+      (\x -> case x of+               OB.AdditionalPropertiesObject s -> pure s+               _                               -> mempty+      )+  , f _schemaAllOf N.toList+  , f _schemaAnyOf N.toList+  , f _schemaOneOf N.toList+  , f _schemaNot pure+  , f _schemaDefinitions H.elems+  ]+  where+    f :: (Schema -> Maybe a) -> (a -> [Schema]) -> [Schema]+    f field nextLevelEmbedded = maybe mempty nextLevelEmbedded (field schema)++    checkDependency :: OB.Dependency Schema -> Maybe Schema+    checkDependency (OB.PropertyDependency _) = Nothing+    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+  -> Value+  -> [FR.Failure ValidatorChain]+validateAny cache sc 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)+  , f _schemaAnyOf (setFailure AnyOf)         (fmap maybeToList . AN.anyOf recurse)+  , f _schemaOneOf (setFailure OneOf)         (fmap maybeToList . AN.oneOf recurse)+  , f _schemaNot   (setFailure NotValidator)  (fmap maybeToList . AN.notVal recurse)+  , refFailures+  ] <> specificValidators+  where+    specificValidators :: [FR.Failure ValidatorChain]+    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+        _        -> mempty++    f = runSingle (_scSchema sc) x++    recurse = descendNextLevel cache sc++    -- 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 =+      case _schemaRef (_scSchema sc) of+        Nothing        -> mempty+        Just reference ->+          maybe [FR.Failure RefResolution (toJSON reference) mempty]+                (fmap (modFailure Ref))+                $ AN.ref scope+                         getReference+                         (\a b -> validateAny cache (SchemaContext a b))+                         reference+                         x+      where+        scope :: Maybe Text+        scope = newResolutionScope (_scURI sc) (_schemaId (_scSchema sc))++        getReference :: Maybe Text -> Maybe Schema+        getReference Nothing  = Just (_startingSchema cache)+        getReference (Just t) = H.lookup t (_cachedSchemas cache)++validateString+  :: Schema+  -> Text+  -> [FR.Failure ValidatorChain]+validateString schema x = concat+  [ f _schemaMaxLength (setFailure MaxLength)        (fmap maybeToList . ST.maxLength)+  , f _schemaMinLength (setFailure MinLength)        (fmap maybeToList . ST.minLength)+  , f _schemaPattern   (setFailure PatternValidator) (fmap maybeToList . ST.patternVal)+  ]+  where+    f = runSingle schema x++validateNumber+  :: Schema+  -> Scientific+  -> [FR.Failure ValidatorChain]+validateNumber schema x = concat+  [ f _schemaMultipleOf (setFailure MultipleOf) (fmap maybeToList . NU.multipleOf)+  , f _schemaMaximum+      (modFailure fMax)+      ( fmap maybeToList+      . NU.maximumVal (fromMaybe False (_schemaExclusiveMaximum schema))+      )+  , f _schemaMinimum+      (modFailure fMin)+      ( fmap maybeToList+      . NU.minimumVal (fromMaybe False (_schemaExclusiveMinimum schema))+      )+  ]+  where+    f = runSingle schema x++    fMax NU.Maximum          = Maximum+    fMax NU.ExclusiveMaximum = ExclusiveMaximum++    fMin NU.Minimum          = Minimum+    fMin NU.ExclusiveMinimum = ExclusiveMinimum++validateArray+  :: SchemaCache Schema+  -> SchemaContext Schema+  -> Vector Value+  -> [FR.Failure ValidatorChain]+validateArray cache (SchemaContext mUri schema) 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)+  , f _schemaItems+      (modFailure fItems)+      (AR.items recurse (_schemaAdditionalItems schema))+  ]+  where+    f = runSingle schema x++    recurse = descendNextLevel cache (SchemaContext mUri schema)++    fItems (AR.Items err)                        = Items err+    fItems AR.AdditionalItemsBoolFailure         = AdditionalItemsBool+    fItems (AR.AdditionalItemsObjectFailure err) = AdditionalItemsObject err++validateObject+  :: SchemaCache Schema+  -> SchemaContext Schema+  -> HashMap Text Value+  -> [FR.Failure ValidatorChain]+validateObject cache (SchemaContext mUri schema) 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)+  , f _schemaDependencies  (modFailure fDeps)         (OB.dependencies recurse)++  , f _schemaProperties+      (modFailure fProp)+      (OB.properties recurse+                     (_schemaPatternProperties schema)+                     (_schemaAdditionalProperties schema))++  , f _schemaPatternProperties+      (modFailure fPatProp)+      (case _schemaProperties schema of+        Just _  -> const (const mempty)+        Nothing -> OB.patternProperties recurse (_schemaAdditionalProperties schema))++  , f _schemaAdditionalProperties+      (modFailure fAddProp)+      (if isJust (_schemaProperties schema) || isJust (_schemaPatternProperties schema)+        then const (const mempty)+        else OB.additionalProperties recurse)+  ]+  where+    f = runSingle schema x++    recurse = descendNextLevel cache (SchemaContext mUri schema)++    fDeps (OB.SchemaDependencyFailure err) = SchemaDependency err+    fDeps OB.PropertyDependencyFailure     = PropertyDependency++    fProp (OB.PropertiesFailure err)   = Properties err+    fProp (OB.PropPatternFailure err)  = PatternProperties err+    fProp (OB.PropAdditionalFailure a) =+      case a of+        OB.APBoolFailure       -> AdditionalPropertiesBool+        OB.APObjectFailure err -> AdditionalPropertiesObject err++    fPatProp (OB.PPFailure err) = PatternProperties err+    fPatProp (OB.PPAdditionalPropertiesFailure a)   =+      case a of+        OB.APBoolFailure       -> AdditionalPropertiesBool+        OB.APObjectFailure err -> AdditionalPropertiesObject err++    fAddProp OB.APBoolFailure         = AdditionalPropertiesBool+    fAddProp (OB.APObjectFailure err) = AdditionalItemsObject err++--------------------------------------------------+-- * Validation (Internal utils)+--------------------------------------------------++descendNextLevel+  :: SchemaCache Schema+  -> SchemaContext Schema+  -> Schema+  -> Value+  -> [FR.Failure ValidatorChain]+descendNextLevel cache (SchemaContext mUri schema) =+  validateAny cache . SchemaContext scope+  where+    scope :: Maybe Text+    scope = newResolutionScope mUri (_schemaId schema)++runSingle+  :: Schema+  -> dta+  -> (Schema -> Maybe val)+  -> (err -> FR.Failure ValidatorChain)+  -> (val -> dta -> [err])+  -> [FR.Failure ValidatorChain]+runSingle schema dta field modifyError validate =+  maybe mempty (\val -> modifyError <$> validate val dta) (field schema)

@@ -1,61 +0,0 @@--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" (_rsData 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" (_rsData s) of-        Just (Bool a) -> if a then ((<=), ExclusiveMinimum) else ((<), Minimum)-        _             -> ((<), Minimum)-minimumVal _ _ _ _ = Nothing

@@ -1,118 +0,0 @@-{-# 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 -> SchemaGraph -> (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

@@ -1,145 +0,0 @@-{-# 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" (_rsData s)-      mAddProp = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsData 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" (_rsData s)) Nothing-  let mPatternProps = patternUnmatched spec g s val-  let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsData 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-  -> SchemaGraph-  -> 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" (_rsData s)) Nothing-  when (H.member "patternProperties" (_rsData 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,334 @@++module Data.JsonSchema.Draft4.Schema where++import qualified Data.HashMap.Strict          as H+import           Data.List.NonEmpty           (NonEmpty)+import           Data.Maybe                   (fromJust, isJust)+import           Data.Scientific++import qualified Data.Validator.Draft4.Any    as AN+import qualified Data.Validator.Draft4.Array  as AR+import qualified Data.Validator.Draft4.Object as OB+import           Data.Validator.Utils+import           Import++data Schema = Schema+  { _schemaVersion              :: Maybe Text+  , _schemaId                   :: Maybe Text+  , _schemaRef                  :: Maybe Text+  , _schemaDefinitions          :: Maybe (HashMap Text Schema)+  -- ^ A standardized location for embedding schemas+  -- to be referenced from elsewhere in the document.+  , _schemaOther                :: HashMap Text Value+  -- ^ Since the JSON document this Schema was built from could+  -- contain schemas anywhere (not just in "definitions" or any+  -- of the other official keys) we save any leftover key/value+  -- pairs not covered by them here.++  , _schemaMultipleOf           :: Maybe Scientific+  , _schemaMaximum              :: Maybe Scientific+  , _schemaExclusiveMaximum     :: Maybe Bool+  , _schemaMinimum              :: Maybe Scientific+  , _schemaExclusiveMinimum     :: Maybe Bool++  , _schemaMaxLength            :: Maybe Int+  , _schemaMinLength            :: Maybe Int+  , _schemaPattern              :: Maybe Text++  , _schemaMaxItems             :: Maybe Int+  , _schemaMinItems             :: Maybe Int+  , _schemaUniqueItems          :: Maybe Bool+  , _schemaItems                :: Maybe (AR.Items Schema)+  -- Note that '_schemaAdditionalItems' is left out of 'runValidate'+  -- because its functionality is handled by '_schemaItems'. It always+  -- validates data unless 'Items' is present.+  , _schemaAdditionalItems      :: Maybe (AR.AdditionalItems Schema)++  , _schemaMaxProperties        :: Maybe Int+  , _schemaMinProperties        :: Maybe Int+  , _schemaRequired             :: Maybe OB.Required+  , _schemaDependencies         :: Maybe (HashMap Text (OB.Dependency Schema))+  , _schemaProperties           :: Maybe (HashMap Text Schema)+  , _schemaPatternProperties    :: Maybe (HashMap Text Schema)+  , _schemaAdditionalProperties :: Maybe (OB.AdditionalProperties Schema)++  , _schemaEnum                 :: Maybe AN.EnumVal+  , _schemaType                 :: Maybe AN.TypeVal+  , _schemaAllOf                :: Maybe (NonEmpty Schema)+  , _schemaAnyOf                :: Maybe (NonEmpty Schema)+  , _schemaOneOf                :: Maybe (NonEmpty Schema)+  , _schemaNot                  :: Maybe Schema+  } deriving (Eq, Show)++emptySchema :: Schema+emptySchema = Schema+  { _schemaVersion              = Nothing+  , _schemaId                   = Nothing+  , _schemaRef                  = Nothing+  , _schemaDefinitions          = Nothing+  , _schemaOther                = mempty++  , _schemaMultipleOf           = Nothing+  , _schemaMaximum              = Nothing+  , _schemaExclusiveMaximum     = Nothing+  , _schemaMinimum              = Nothing+  , _schemaExclusiveMinimum     = Nothing++  , _schemaMaxLength            = Nothing+  , _schemaMinLength            = Nothing+  , _schemaPattern              = Nothing++  , _schemaMaxItems             = Nothing+  , _schemaMinItems             = Nothing+  , _schemaUniqueItems          = Nothing+  , _schemaItems                = Nothing+  , _schemaAdditionalItems      = Nothing++  , _schemaMaxProperties        = Nothing+  , _schemaMinProperties        = Nothing+  , _schemaRequired             = Nothing+  , _schemaDependencies         = Nothing+  , _schemaProperties           = Nothing+  , _schemaPatternProperties    = Nothing+  , _schemaAdditionalProperties = Nothing++  , _schemaEnum                 = Nothing+  , _schemaType                 = Nothing+  , _schemaAllOf                = Nothing+  , _schemaAnyOf                = Nothing+  , _schemaOneOf                = Nothing+  , _schemaNot                  = Nothing+  }++instance FromJSON Schema where+  parseJSON = withObject "Schema" $ \o -> do+    a  <- o .:? "$schema"+    b  <- o .:? "id"+    c  <- o .:? "$ref"+    d  <- o .:? "definitions"+    e  <- parseJSON (Object (H.difference o internalSchemaHashMap))++    f  <- o .:? "multipleOf"+    g  <- o .:? "maximum"+    h  <- o .:? "exclusiveMaximum"+    i  <- o .:? "minimum"+    j  <- o .:? "exclusiveMinimum"++    k  <- o .:? "maxLength"+    l  <- o .:? "minLength"+    m  <- o .:? "pattern"++    n  <- o .:? "maxItems"+    o' <- o .:? "minItems"+    p  <- o .:? "uniqueItems"+    q  <- o .:? "items"+    r  <- o .:? "additionalItems"++    s  <- o .:? "maxProperties"+    t  <- o .:? "minProperties"+    u  <- o .:? "required"+    v  <- o .:? "dependencies"+    w  <- o .:? "properties"+    x  <- o .:? "patternProperties"+    y  <- o .:? "additionalProperties"++    z  <- o .:? "enum"+    a2 <- o .:? "type"+    b2 <- fmap _unNonEmpty' <$> o .:? "allOf"+    c2 <- fmap _unNonEmpty' <$> o .:? "anyOf"+    d2 <- fmap _unNonEmpty' <$> o .:? "oneOf"+    e2 <- o .:? "not"+    pure Schema+      { _schemaVersion              = a+      , _schemaId                   = b+      , _schemaRef                  = c+      , _schemaDefinitions          = d+      , _schemaOther                = e++      , _schemaMultipleOf           = f+      , _schemaMaximum              = g+      , _schemaExclusiveMaximum     = h+      , _schemaMinimum              = i+      , _schemaExclusiveMinimum     = j++      , _schemaMaxLength            = k+      , _schemaMinLength            = l+      , _schemaPattern              = m++      , _schemaMaxItems             = n+      , _schemaMinItems             = o'+      , _schemaUniqueItems          = p+      , _schemaItems                = q+      , _schemaAdditionalItems      = r++      , _schemaMaxProperties        = s+      , _schemaMinProperties        = t+      , _schemaRequired             = u+      , _schemaDependencies         = v+      , _schemaProperties           = w+      , _schemaPatternProperties    = x+      , _schemaAdditionalProperties = y++      , _schemaEnum                 = z+      , _schemaType                 = a2+      , _schemaAllOf                = b2+      , _schemaAnyOf                = c2+      , _schemaOneOf                = d2+      , _schemaNot                  = e2+      }++instance ToJSON Schema where+  -- | The way we resolve JSON Pointers to embedded schemas is by+  -- serializing the containing schema to a value and then resolving the+  -- pointer against it. This means that FromJSON and ToJSON must be+  -- isomorphic.+  --+  -- This influences the design choices in the library. E.g. right now+  -- there are two false values for "exclusiveMaximum" -- Nothing and+  -- Just False. We could have condensed them down by using () instead+  -- of Bool for "exclusiveMaximum". This would have made writing schemas+  -- in haskell easier, but we could no longer round trip through/from+  -- JSON without losing information.+  toJSON s = Object $ H.union (mapMaybe ($ s) internalSchemaHashMap) (toJSON <$> _schemaOther s)+    where+      -- 'mapMaybe' is provided by unordered-containers after unordered-container-2.6.0.0,+      -- but until that is a little older (and has time to get into Stackage etc.)+      -- we use our own implementation.+      mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+      mapMaybe f = fmap fromJust . H.filter isJust . fmap f++-- | Internal. Separate from ToJSON because it's also used+-- by FromJSON to determine what keys aren't official schema+-- keys and therefor should be included in _schemaOther.+internalSchemaHashMap :: HashMap Text (Schema -> Maybe Value)+internalSchemaHashMap = H.fromList+  [ ("$schema"             , f _schemaVersion)+  , ("id"                  , f _schemaId)+  , ("$ref"                , f _schemaRef)+  , ("definitions"         , f _schemaDefinitions)++  , ("multipleOf"          , f _schemaMultipleOf)+  , ("maximum"             , f _schemaMaximum)+  , ("exclusiveMaximum"    , f _schemaExclusiveMaximum)+  , ("minimum"             , f _schemaMinimum)+  , ("exclusiveMinimum"    , f _schemaExclusiveMinimum)++  , ("maxLength"           , f _schemaMaxLength)+  , ("minLength"           , f _schemaMinLength)+  , ("pattern"             , f _schemaPattern)++  , ("maxItems"            , f _schemaMaxItems)+  , ("minItems"            , f _schemaMinItems)+  , ("uniqueItems"         , f _schemaUniqueItems)+  , ("items"               , f _schemaItems)+  , ("additionalItems"     , f _schemaAdditionalItems)++  , ("maxProperties"       , f _schemaMaxProperties)+  , ("minProperties"       , f _schemaMinProperties)+  , ("required"            , f _schemaRequired)+  , ("dependencies"        , f _schemaDependencies)+  , ("properties"          , f _schemaProperties)+  , ("patternProperties"   , f _schemaPatternProperties)+  , ("additionalProperties", f _schemaAdditionalProperties)++  , ("enum"                , f _schemaEnum)+  , ("type"                , f _schemaType)+  , ("allOf"               , f (fmap NonEmpty' . _schemaAllOf))+  , ("anyOf"               , f (fmap NonEmpty' . _schemaAnyOf))+  , ("oneOf"               , f (fmap NonEmpty' . _schemaOneOf))+  , ("not"                 , f _schemaNot)+  ]+  where+    f :: ToJSON a => (Schema -> Maybe a) -> Schema -> Maybe Value+    f = (fmap.fmap) toJSON++instance Arbitrary Schema where+  arbitrary = sized f+    where+      maybeGen :: Gen a -> Gen (Maybe a)+      maybeGen a = oneof [pure Nothing, Just <$> a]++      maybeRecurse :: Int -> Gen a -> Gen (Maybe a)+      maybeRecurse n a+        | n < 1     = pure Nothing+        | otherwise = maybeGen $ resize (n `div` 10) a++      f :: Int -> Gen Schema+      f n = do+        a  <- maybeGen arbitraryText+        b  <- maybeGen arbitraryText+        c  <- maybeGen arbitraryText+           -- NOTE: The next two fields are empty to generate cleaner schemas,+           -- but note that this means we don't test e.g. the invertability+           -- of these fields.+        d  <- pure Nothing -- _schemaDefinitions+        e  <- pure mempty -- _otherPairs++        f' <- maybeGen arbitraryPositiveScientific+        g  <- maybeGen arbitraryScientific+        h  <- arbitrary+        i  <- maybeGen arbitraryScientific+        j  <- arbitrary++        k  <- maybeGen (getPositive <$> arbitrary)+        l  <- maybeGen (getPositive <$> arbitrary)+        m  <- maybeGen arbitraryText++        n' <- maybeGen (getPositive <$> arbitrary)+        o  <- maybeGen (getPositive <$> arbitrary)+        p  <- arbitrary+        q  <- maybeRecurse n arbitrary+        r  <- maybeRecurse n arbitrary++        s  <- maybeGen (getPositive <$> arbitrary)+        t  <- maybeGen (getPositive <$> arbitrary)+        u  <- arbitrary+        v  <- maybeRecurse n arbitraryHashMap+        w  <- maybeRecurse n arbitraryHashMap+        x  <- maybeRecurse n arbitraryHashMap+        y  <- maybeRecurse n arbitrary++        z  <- arbitrary+        a2 <- arbitrary+        b2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+        c2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+        d2 <- maybeRecurse n (_unNonEmpty' <$> arbitrary)+        e2 <- maybeRecurse n arbitrary+        pure Schema+          { _schemaVersion              = a+          , _schemaId                   = b+          , _schemaRef                  = c+          , _schemaDefinitions          = d+          , _schemaOther                = e++          , _schemaMultipleOf           = f'+          , _schemaMaximum              = g+          , _schemaExclusiveMaximum     = h+          , _schemaMinimum              = i+          , _schemaExclusiveMinimum     = j++          , _schemaMaxLength            = k+          , _schemaMinLength            = l+          , _schemaPattern              = m++          , _schemaMaxItems             = n'+          , _schemaMinItems             = o+          , _schemaUniqueItems          = p+          , _schemaItems                = q+          , _schemaAdditionalItems      = r++          , _schemaMaxProperties        = s+          , _schemaMinProperties        = t+          , _schemaRequired             = u+          , _schemaDependencies         = v+          , _schemaProperties           = w+          , _schemaPatternProperties    = x+          , _schemaAdditionalProperties = y++          , _schemaEnum                 = z+          , _schemaType                 = a2+          , _schemaAllOf                = b2+          , _schemaAnyOf                = c2+          , _schemaOneOf                = d2+          , _schemaNot                  = e2+          }

@@ -1,44 +0,0 @@--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

@@ -0,0 +1,133 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.JsonSchema.Fetch where++import           Control.Exception        (SomeException(..), catch)+import qualified Data.ByteString.Lazy     as LBS+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           Import++-- For GHCs before 7.10:+import           Prelude                  hiding (concat, sequence)++data SchemaContext schema = SchemaContext+  { _scURI    :: !(Maybe Text)+  -- ^ Must not include a URI fragment, e.g. use+  -- "http://example.com/foo" not "http://example.com/foo#bar".+  --+  -- This is the URI identifying the document containing the schema.+  -- It's different than the schema's "id" field, which controls scope+  -- 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+  -- ^ Used to resolve relative references.+  , _cachedSchemas  :: !(URISchemaMap schema)+  } deriving (Eq, Show)++-- | Take a schema. Retrieve every document either it or its subschemas+-- include via the "$ref" keyword. Load a 'SchemaCache' out with them.+fetchReferencedSchemas+  :: 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+  manager <- newManager defaultManagerSettings+  catch (Right <$> f manager) handler+  where+    f manager = fetchReferencedSchemas' embedded getId getRef+                                        (simpleGET manager) cache sc++    handler :: SomeException -> IO (Either Text (SchemaCache schema))+    handler e = pure . Left . T.pack . show $ e++-- | 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++-- | 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'+  :: forall schema. FromJSON schema+  => (schema -> [schema])+  -> (schema -> Maybe Text)+  -> (schema -> Maybe Text)+  -> (Text -> IO LBS.ByteString)+  -> 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)+  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++-- | 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)+  where+    subSchemas :: [SchemaContext schema]+    subSchemas = SchemaContext (newResolutionScope mUri (getId schema))+             <$> embedded schema

@@ -1,160 +0,0 @@--module Data.JsonSchema.Helpers where--import           Control.Exception-import qualified Data.ByteString.Lazy as LBS-import qualified Data.HashMap.Strict  as H-import           Data.Scientific-import qualified Data.Set as S-import qualified Data.Text            as T-import qualified Data.Vector          as V-import           Network.HTTP.Client--import           Data.JsonSchema.Core-import           Import------------------------------------------------------- * Embedded schemas finders-----------------------------------------------------noEm :: EmbeddedSchemas-noEm _ _ = mempty--objEmbed :: EmbeddedSchemas-objEmbed t (Object o) = pure (RawSchema t o)-objEmbed _ _ = mempty--arrayEmbed :: EmbeddedSchemas-arrayEmbed t (Array vs) = objEmbed t =<< V.toList vs-arrayEmbed _ _ = mempty--objOrArrayEmbed :: EmbeddedSchemas-objOrArrayEmbed t v@(Object _) = objEmbed t v-objOrArrayEmbed t v@(Array _) = arrayEmbed t v-objOrArrayEmbed _ _ = mempty--objMembersEmbed :: EmbeddedSchemas-objMembersEmbed t (Object o) = objEmbed t =<< H.elems o-objMembersEmbed _ _ = mempty------------------------------------------------------- * Modify Validators for use in Specs-----------------------------------------------------giveName-  :: forall err. err-  -> ValidatorConstructor err [FailureInfo]-  -> ValidatorConstructor err [ValidationFailure err]-giveName err f spec g rs v = (fmap.fmap) (ValidationFailure err) <$> f spec g rs v--modifyName-  :: forall valErr schemaErr. (valErr -> schemaErr)-  -> ValidatorConstructor schemaErr [ValidationFailure valErr]-  -> ValidatorConstructor schemaErr [ValidationFailure schemaErr]-modifyName failureHandler f spec g rs v = (fmap.fmap) modErr <$> f spec g rs v-  where-    modErr :: ValidationFailure valErr -> ValidationFailure schemaErr-    modErr (ValidationFailure a b) = ValidationFailure (failureHandler a) b---- | 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------------------------------------------------------- | 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--    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--runMaybeVal :: Maybe (Value -> [a]) -> Value -> [a]-runMaybeVal Nothing _ = mempty-runMaybeVal (Just val) x = val x--runMaybeVal'-  :: Maybe (Value -> ([a], Value))-  -> Value-  -> ([a], Value)-runMaybeVal' Nothing x = (mempty, x)-runMaybeVal' (Just val) x = val x--toObj :: Value -> Maybe (HashMap Text Value)-toObj (Object a) = Just a-toObj _ = Nothing--fromJSONInt :: Value -> Maybe Int-fromJSONInt (Number n) = toBoundedInteger n-fromJSONInt _ = Nothing--toTxt :: Value -> Maybe Text-toTxt (String t) = Just t-toTxt _ = Nothing--greaterThanZero :: (Num a, Ord a) => a -> Maybe ()-greaterThanZero n = if n <= 0 then Nothing else Just ()--tshow :: Show a => a -> Text-tshow = T.pack . show--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)

@@ -1,65 +0,0 @@--module Data.JsonSchema.Reference where--import qualified Data.HashMap.Strict    as H-import           Data.JsonPointer-import qualified Data.Text              as T-import           Data.Text.Encoding-import           Network.HTTP.Types.URI--import           Import--type URIBase = Maybe Text-type URIBaseAndFragment = (Maybe Text, Maybe Text)--newResolutionScope :: URIBase -> HashMap Text Value -> URIBase-newResolutionScope mScope o =-  case H.lookup "id" o of-    Just (String t) -> fst . baseAndFragment $ resolveScopeAgainst mScope t-    _               -> mScope--resolveReference :: URIBase -> Text -> URIBaseAndFragment-resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t--isRemoteReference :: Text -> Bool-isRemoteReference uri = "://" `T.isInfixOf` uri--resolveFragment :: Maybe Text -> HashMap Text Value -> HashMap Text Value-resolveFragment Nothing hm        = hm-resolveFragment (Just pointer) hm =-  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer-  in case jsonPointer urlDecoded of-    Left _  -> hm-    Right p ->-      case resolvePointer p (Object hm) of-        Right (Object hm') -> hm'-        _                  -> hm------------------------------------------------------- * Internal-----------------------------------------------------baseAndFragment :: Text -> URIBaseAndFragment-baseAndFragment = f . T.splitOn "#"-  where-    f :: [Text] -> URIBaseAndFragment-    f [x]   = (g x, Nothing)-    f [x,y] = (g x, g y)-    f _     = (Nothing, Nothing)--    g "" = Nothing-    g x  = Just x--resolveScopeAgainst :: Maybe Text -> Text -> Text-resolveScopeAgainst Nothing t = t-resolveScopeAgainst (Just scope) t-  | isRemoteReference t = t-  | otherwise           = smartAppend-  where-    -- There shouldn't be a fragment at the end of a scope URI,-    -- 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

@@ -0,0 +1,8 @@++module Data.Validator.Draft4 (module Export) where++import           Data.Validator.Draft4.Any    as Export+import           Data.Validator.Draft4.Array  as Export+import           Data.Validator.Draft4.Number as Export+import           Data.Validator.Draft4.Object as Export+import           Data.Validator.Draft4.String as Export

@@ -0,0 +1,179 @@++module Data.Validator.Draft4.Any where++import           Control.Monad+import           Data.Aeson.Types         (Parser)+import           Data.List.NonEmpty       (NonEmpty)+import qualified Data.List.NonEmpty       as N+import           Data.Maybe+import           Data.Scientific+import           Data.Set                 (Set)+import qualified Data.Set                 as S++import           Data.Validator.Failure+import           Data.Validator.Utils+import           Data.Validator.Reference+import           Import++-- For GHCs before 7.10:+import           Prelude hiding           (any)++--------------------------------------------------+-- * $ref+--------------------------------------------------++-- | Will return 'Nothing' if the reference can't be resolved.+ref+  :: forall err schema. (FromJSON schema, ToJSON schema, Show schema)+  => Maybe Text+  -> (Maybe Text -> Maybe schema)+  -> (Maybe Text -> schema -> Value -> [Failure err])+  -> Text+  -> Value+  -> Maybe [Failure err]+ref scope getRef f reference x = do+  let (mUri, mFragment) = resolveReference scope reference+  schema <- getRef mUri+  s      <- resolveFragment mFragment schema+  Just (f mUri s x)++--------------------------------------------------+-- * enum+--------------------------------------------------++-- | From the spec:+-- <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.+--+-- NOTE: We don't enforce the uniqueness constraint in the haskell code,+-- but we do in the 'FromJSON' instance.+newtype EnumVal+  = EnumVal { _unEnumVal :: NonEmpty Value }+  -- Given a choice, we'd prefer to enforce uniqueness through the type+  -- system over having at least one element. To use a 'Set' though we'd+  -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)+  -- and we'd rather not make users mess with 'OrdValue'.+  deriving (Eq, Show)++instance FromJSON EnumVal where+  parseJSON v = checkUnique . _unNonEmpty' =<< parseJSON v+    where+      checkUnique :: NonEmpty Value -> Parser EnumVal+      checkUnique a+        | allUniqueValues' a = pure (EnumVal a)+        | otherwise = fail "All elements of the Enum validator must be unique."++instance ToJSON EnumVal where+  toJSON = toJSON . NonEmpty' . _unEnumVal++instance Arbitrary EnumVal where+  arbitrary = do+    xs <- traverse (const arbitraryValue) =<< (arbitrary :: Gen [()])+    case N.nonEmpty (toUnique xs) of+      Nothing -> EnumVal . pure <$> arbitraryValue+      Just ne -> pure (EnumVal ne)+    where+      toUnique :: [Value] -> [Value]+      toUnique = fmap _unOrdValue . S.toList . S.fromList . fmap OrdValue++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++--------------------------------------------------+-- * type+--------------------------------------------------++data TypeVal+  = TypeValString Text+  | TypeValArray (Set Text)+  deriving (Eq, Show)++instance FromJSON TypeVal where+  parseJSON v = fmap TypeValString (parseJSON v)+            <|> fmap TypeValArray (parseJSON v)++instance ToJSON TypeVal where+  toJSON (TypeValString t) = toJSON t+  toJSON (TypeValArray ts) = toJSON ts++instance Arbitrary TypeVal where+  arbitrary = oneof [ TypeValString <$> arbitraryText+                    , TypeValArray <$> arbitrarySetOfText+                    ]++typeVal :: TypeVal -> Value -> Maybe (Failure ())+typeVal (TypeValString t) x = isJsonType x (S.singleton t)+typeVal (TypeValArray ts) x = isJsonType x ts++isJsonType :: Value -> Set Text -> Maybe (Failure ())+isJsonType x ts+  | S.null (S.intersection okTypes ts) = Just (Failure () (toJSON ts) mempty)+  | otherwise                          = Nothing+  where+    okTypes :: Set Text+    okTypes =+      case x of+        Null       -> S.singleton "null"+        (Array _)  -> S.singleton "array"+        (Bool _)   -> S.singleton "boolean"+        (Object _) -> S.singleton "object"+        (String _) -> S.singleton "string"+        (Number y) ->+          case toBoundedInteger y :: Maybe Int of+            Nothing -> S.singleton "number"+            Just _  -> S.fromList ["number", "integer"]++--------------------------------------------------+-- * other+--------------------------------------------------++allOf+  :: (schema -> Value -> [Failure err])+  -> NonEmpty schema+  -> Value+  -> [Failure err]+allOf f subSchemas x = N.toList subSchemas >>= flip f x++anyOf+  :: ToJSON schema+  => (schema -> Value -> [Failure err])+  -> NonEmpty schema+  -> Value+  -> Maybe (Failure ())+anyOf f subSchemas x+  | any null (flip f x <$> subSchemas) = Nothing+  | otherwise = Just $ Failure () (toJSON (NonEmpty' subSchemas)) mempty++oneOf+  :: forall err schema. ToJSON schema+  => (schema -> Value -> [Failure err])+  -> NonEmpty schema+  -> Value+  -> Maybe (Failure ())+oneOf f subSchemas x+  | length successes == 1 = Nothing+  | otherwise             = Just $ Failure ()+                                           (toJSON (NonEmpty' subSchemas))+                                           mempty+  where+    successes :: [[Failure err]]+    successes = filter null $ flip f x <$> N.toList subSchemas++notVal+  :: ToJSON schema+  => (schema -> Value -> [Failure err])+  -> schema+  -> Value+  -> Maybe (Failure ())+notVal f schema x =+  case f schema x of+    [] -> Just (Failure () (toJSON schema) mempty)+    _  -> Nothing

@@ -0,0 +1,168 @@++module Data.Validator.Draft4.Array where++import           Control.Monad+import qualified Data.Aeson.Pointer     as P+import qualified Data.Text              as T+import qualified Data.Vector            as V+import           Text.Read              (readMaybe)++import           Data.Validator.Failure+import           Data.Validator.Utils   (allUniqueValues)+import           Import++-- | The spec requires "maxItems" to be non-negative.+maxItems :: Int -> Vector Value -> Maybe (Failure ())+maxItems n xs+  | n < 0           = Nothing+  | V.length xs > n = Just (Failure () (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)+  | otherwise       = Nothing++uniqueItems :: Bool -> Vector Value -> Maybe (Failure ())+uniqueItems True xs+  | allUniqueValues xs = Nothing+  | otherwise          = Just (Failure () (Bool True) mempty)+uniqueItems False _ = Nothing++--------------------------------------------------+-- * items+--------------------------------------------------++data ItemsFailure err+  = Items err+  | AdditionalItemsBoolFailure+  | AdditionalItemsObjectFailure err+  deriving (Eq, Show)++data Items schema+  = ItemsObject schema+  | ItemsArray [schema]+  deriving (Eq, Show)++instance FromJSON schema => FromJSON (Items schema) where+  parseJSON v = fmap ItemsObject (parseJSON v)+            <|> fmap ItemsArray (parseJSON v)++instance ToJSON schema => ToJSON (Items schema) where+  toJSON (ItemsObject hm)     = toJSON hm+  toJSON (ItemsArray schemas) = toJSON schemas++instance Arbitrary schema => Arbitrary (Items schema) where+  arbitrary = oneof [ ItemsObject <$> arbitrary+                    , ItemsArray <$> arbitrary+                    ]++items+  :: forall err schema.+     (schema -> Value -> [Failure err])+  -> Maybe (AdditionalItems schema)+  -> Items schema+  -> Vector Value+  -> [Failure (ItemsFailure err)]+items f _ (ItemsObject subSchema) xs = zip [0..] (V.toList xs) >>= g+  where+    g :: (Int, Value) -> [Failure (ItemsFailure err)]+    g (index,x) = modFailure Items+                . addToPath (P.Token (T.pack (show index)))+              <$> f subSchema x++items f mAdditional (ItemsArray subSchemas) xs = itemFailures+                                              <> additionalItemFailures+  where+    indexedValues :: [(Int, Value)]+    indexedValues = zip [0..] (V.toList xs)++    itemFailures :: [Failure (ItemsFailure err)]+    itemFailures = join (zipWith g subSchemas indexedValues)+      where+        g :: schema -> (Int, Value) -> [Failure (ItemsFailure err)]+        g schema (index,x) = modFailure Items+                           . addToPath (P.Token (T.pack (show index)))+                         <$> f schema x++    additionalItemFailures :: [Failure (ItemsFailure err)]+    additionalItemFailures =+      case mAdditional of+        Nothing  -> mempty+        Just adi -> modFailure correctName+                  . correctIndexes+                <$> additionalItems f adi extras+      where+        -- It's not great that we convert back to Vector again.+        extras :: Vector Value+        extras =+          V.fromList . fmap snd . drop (length subSchemas) $ indexedValues++        -- Since 'additionalItems' only sees part of the array, but starts+        -- indexing from zero, we need to modify the paths it reports to+        -- 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)+          where+            fixIndex :: P.Pointer -> P.Pointer+            fixIndex (P.Pointer (tok:toks)) =+              case readMaybe . T.unpack . P._unToken $ tok of+                Nothing -> P.Pointer $ tok:toks+                Just n  -> P.Pointer $+                  (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++--------------------------------------------------+-- * additionalItems+--------------------------------------------------++data AdditionalItemsFailure err+  = AdditionalBoolFailure+  | AdditionalObjectFailure err+  deriving (Eq, Show)++data AdditionalItems schema+  = AdditionalBool Bool+  | AdditionalObject schema+  deriving (Eq, Show)++instance FromJSON schema => FromJSON (AdditionalItems schema) where+  parseJSON v = fmap AdditionalBool (parseJSON v)+            <|> fmap AdditionalObject (parseJSON v)++instance ToJSON schema => ToJSON (AdditionalItems schema) where+  toJSON (AdditionalBool b)    = toJSON b+  toJSON (AdditionalObject hm) = toJSON hm++instance Arbitrary schema => Arbitrary (AdditionalItems schema) where+  arbitrary = oneof [ AdditionalBool <$> arbitrary+                    , AdditionalObject <$> arbitrary+                    ]++additionalItems+  :: forall err schema.+     (schema -> Value -> [Failure err])+  -> AdditionalItems schema+  -> Vector Value+  -> [Failure (AdditionalItemsFailure err)]+additionalItems _ (AdditionalBool b) xs+  | b               = mempty+  | V.length xs > 0 = pure (Failure AdditionalBoolFailure (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+                . addToPath (P.Token (T.pack (show index)))+              <$> f subSchema x

@@ -0,0 +1,51 @@++module Data.Validator.Draft4.Number where++import           Data.Fixed             (mod')+import           Data.Scientific++import           Data.Validator.Failure+import           Import++-- | The spec requires "multipleOf" to be positive.+multipleOf :: Scientific -> Scientific -> Maybe (Failure ())+multipleOf n x+  | n <= 0          = Nothing+  | x `mod'` n /= 0 = Just (Failure () (toJSON n) mempty)+  | otherwise       = Nothing++data MaximumFailure+  = Maximum+  | ExclusiveMaximum+  deriving (Eq, Show)++maximumVal+  :: Bool+  -> Scientific+  -> Scientific+  -> Maybe (Failure MaximumFailure)+maximumVal exclusiveMaximum n x+  | x `greaterThan` n = Just (Failure err (toJSON n) mempty)+  | otherwise         = Nothing+  where+    (greaterThan, err) = if exclusiveMaximum+                           then ((>=), ExclusiveMaximum)+                           else ((>), Maximum)++data MinimumFailure+  = Minimum+  | ExclusiveMinimum+  deriving (Eq, Show)++minimumVal+  :: Bool+  -> Scientific+  -> Scientific+  -> Maybe (Failure MinimumFailure)+minimumVal exclusiveMinimum n x+  | x `lessThan` n = Just (Failure err (toJSON n) mempty)+  | otherwise      = Nothing+  where+    (lessThan, err) = if exclusiveMinimum+                        then ((<=), ExclusiveMinimum)+                        else ((<), Minimum)

@@ -0,0 +1,147 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}++module Data.Validator.Draft4.Object+  ( module Data.Validator.Draft4.Object+  , module Data.Validator.Draft4.Object.Properties+  ) where++import           Data.Aeson.Types                        (Parser)+import qualified Data.HashMap.Strict                     as H+import           Data.Set                                (Set)+import qualified Data.Set                                as S+import qualified Data.Text                               as T++import           Data.Validator.Draft4.Object.Properties+import           Data.Validator.Failure+import           Data.Validator.Utils+import           Import++-- For GHCs before 7.10:+import           Prelude                                 hiding (all, concat,+                                                          foldl)++-- | The spec requires "maxProperties" to be non-negative.+maxProperties :: Int -> HashMap Text Value -> Maybe (Failure ())+maxProperties n x+  | n < 0        = Nothing+  | H.size x > n = Just (Failure () (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)+  | otherwise    = Nothing++--------------------------------------------------+-- * required+--------------------------------------------------++-- | From the spec:+--+-- > The value of this keyword MUST be an array.+-- > This array MUST have at least one element.+-- > Elements of this array MUST be strings, and MUST be unique.+--+-- We don't enfore that 'Required' has at least one element in the+-- haskell code, but we do in the 'FromJSON' instance.+newtype Required+  = Required { _unRequired :: Set Text }+  deriving (Eq, Show, ToJSON)++instance FromJSON Required where+  parseJSON v = checkUnique =<< checkSize =<< parseJSON v+    where+      checkSize :: [Text] -> Parser [Text]+      checkSize a+        | null a    = fail "Required validator must not be empty."+        | otherwise = pure a++      checkUnique :: [Text] -> Parser Required+      checkUnique a =+        let b = S.fromList a+        -- NOTE: Can use length instead of S.size in GHC 7.10 or later.+        in if length a == S.size b+          then pure (Required b)+          else fail "All elements of the Required validator must be unique."++instance Arbitrary Required where+  arbitrary = do+    x  <- arbitraryText -- Guarantee at least one element.+    xs <- (fmap.fmap) T.pack arbitrary+    pure . Required . S.fromList $ x:xs++required :: Required -> HashMap Text Value -> Maybe (Failure ())+required (Required ts) x+  -- NOTE: When we no longer need to support GHCs before 7.10+  -- we can use null from Prelude throughout the library+  -- instead of specialized versions.+  | S.null ts                  = Nothing+  | H.null (H.difference hm x) = Nothing+  | otherwise                  = Just (Failure () (toJSON ts) mempty)+  where+    hm :: HashMap Text Bool+    hm = foldl (\b a -> H.insert a True b) mempty ts++--------------------------------------------------+-- * dependencies+--------------------------------------------------++data DependencyFailure err+  = SchemaDependencyFailure err+  | PropertyDependencyFailure+  deriving (Eq, Show)++data Dependency schema+  = SchemaDependency schema+  | PropertyDependency (Set Text)+  deriving (Eq, Show)++instance FromJSON schema => FromJSON (Dependency schema) where+  parseJSON v = fmap SchemaDependency (parseJSON v)+            <|> fmap PropertyDependency (parseJSON v)++instance ToJSON schema => ToJSON (Dependency schema) where+  toJSON (SchemaDependency schema) = toJSON schema+  toJSON (PropertyDependency ts)   = toJSON ts++instance Arbitrary schema => Arbitrary (Dependency schema) where+  arbitrary = oneof [ SchemaDependency <$> arbitrary+                    , PropertyDependency <$> arbitrarySetOfText+                    ]++-- | From the spec:+-- <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+  :: forall err schema. (schema -> Value -> [Failure err])+  -> HashMap Text (Dependency schema)+  -> HashMap Text Value+  -> [Failure (DependencyFailure err)]+dependencies f hm x = concat . fmap (uncurry g) . H.toList $ hm+  where+    g :: Text -> Dependency schema -> [Failure (DependencyFailure err)]+    g k (SchemaDependency schema)+      | H.member k x =+        modFailure SchemaDependencyFailure <$> f schema (Object x)+      | otherwise    = mempty+    g k (PropertyDependency ts)+      | H.member k x && not allPresent =+        pure $ Failure PropertyDependencyFailure+                       (toJSON (H.singleton k ts))+                       mempty+      | otherwise = mempty+      where+        allPresent :: Bool+        allPresent = all (`H.member` x) ts

@@ -0,0 +1,187 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Validator.Draft4.Object.Properties where++import           Control.Monad+import           Data.Aeson+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.Validator.Failure+import           Import++newtype Remaining = Remaining { _unRemaining :: HashMap Text Value }++--------------------------------------------------+-- * properties+--------------------------------------------------++data PropertiesFailure err+  = PropertiesFailure err+  | PropPatternFailure err+  | PropAdditionalFailure (AdditionalPropertiesFailure err)+  deriving (Eq, Show)++-- | In order of what's tried: "properties", "patternProperties",+-- "additionalProperties".+properties+  :: forall err schema.+     (schema -> Value -> [Failure err])+  -> Maybe (HashMap Text schema)+  -> Maybe (AdditionalProperties schema)+  -> HashMap Text schema+  -> HashMap Text Value+  -> [Failure (PropertiesFailure err)]+properties f mPat mAdd propertiesHm x =+     fmap (modFailure PropertiesFailure) propFailures+  <> fmap (modFailure PropPatternFailure) patternFailures+  <> fmap (modFailure PropAdditionalFailure) additionalFailures+  where+    propertiesAndUnmatched :: ([Failure err], Remaining)+    propertiesAndUnmatched = ( failures+                             , Remaining (H.difference x propertiesHm)+                             )+      where+        failures :: [Failure err]+        failures = H.toList (H.intersectionWith f propertiesHm x)+               >>= (\(k,vs) -> fmap (addToPath (P.Token k)) vs)++    (propFailures, remaining1) = propertiesAndUnmatched++    mPatProp :: Maybe (HashMap Text Value -> ([Failure err], Remaining))+    mPatProp = patternAndUnmatched f <$> mPat++    patternFailures :: [Failure err]+    patternFailures = case mPatProp of+                        Nothing  -> mempty+                        Just val -> fst (val x)++    remaining2 :: Remaining+    remaining2 = case mPatProp of+                   Nothing  -> remaining1+                   Just val -> snd . val . _unRemaining $ remaining1++    additionalFailures :: [Failure (AdditionalPropertiesFailure err)]+    additionalFailures = case additionalProperties f <$> mAdd of+                           Nothing  -> mempty+                           Just val -> val (_unRemaining remaining2)++--------------------------------------------------+-- * patternProperties+--------------------------------------------------++data PatternPropertiesFailure err+  = PPFailure err+  | PPAdditionalPropertiesFailure (AdditionalPropertiesFailure err)+  deriving (Eq, Show)++patternProperties+  :: forall err schema.+     (schema -> Value -> [Failure err])+  -> Maybe (AdditionalProperties schema)+  -> HashMap Text schema+  -> HashMap Text Value+  -> [Failure (PatternPropertiesFailure err)]+patternProperties f mAdd patternPropertiesHm x =+     fmap (modFailure PPFailure) ppFailures+  <> fmap (modFailure PPAdditionalPropertiesFailure) addFailures+  where+    patternProps :: ([Failure err], Remaining)+    patternProps = patternAndUnmatched f patternPropertiesHm x++    (ppFailures, remaining) = patternProps++    addFailures :: [Failure (AdditionalPropertiesFailure err)]+    addFailures = case additionalProperties f <$> mAdd of+                    Nothing  -> mempty+                    Just val -> val (_unRemaining remaining)++patternAndUnmatched+  :: forall err schema.+     (schema -> Value -> [Failure err])+  -> HashMap Text schema+  -> HashMap Text Value+  -> ([Failure err], Remaining)+patternAndUnmatched f patPropertiesHm x =+  (H.foldlWithKey' runVals mempty perhapsMatches, remaining)+  where+    perhapsMatches :: HashMap Text (Value, [schema])+    perhapsMatches = H.foldlWithKey' (matchingSchemas patPropertiesHm) mempty x+      where+        matchingSchemas+          :: HashMap Text schema+          -> HashMap Text (Value, [schema])+          -> Text+          -> Value+          -> HashMap Text (Value, [schema])+        matchingSchemas subSchemas acc k v =+          H.insert k (v, H.foldlWithKey' (checkKey k) mempty subSchemas) acc++        checkKey+          :: Text+          -> [schema]+          -> Text+          -> schema+          -> [schema]+        checkKey k acc r subSchema =+          case matchRegexPR (T.unpack r) (T.unpack k) of+            Nothing -> acc+            Just _  -> pure subSchema <> acc++    runVals+      :: [Failure err]+      -> Text+      -> (Value, [schema])+      -> [Failure err]+    runVals acc k (v,subSchemas) =+      (subSchemas >>= (\schema -> addToPath (P.Token k) <$> f schema v))+      <> acc++    remaining :: Remaining+    remaining = Remaining . fmap fst . H.filter (null . snd) $ perhapsMatches++--------------------------------------------------+-- * additionalProperties+--------------------------------------------------++data AdditionalPropertiesFailure err+  = APBoolFailure+  | APObjectFailure err+  deriving (Eq, Show)++data AdditionalProperties schema+  = AdditionalPropertiesBool Bool+  | AdditionalPropertiesObject schema+  deriving (Eq, Show)++instance FromJSON schema => FromJSON (AdditionalProperties schema) where+  parseJSON v = fmap AdditionalPropertiesBool (parseJSON v)+            <|> fmap AdditionalPropertiesObject (parseJSON v)++instance ToJSON schema => ToJSON (AdditionalProperties schema) where+  toJSON (AdditionalPropertiesBool b)    = toJSON b+  toJSON (AdditionalPropertiesObject hm) = toJSON hm++instance Arbitrary schema => Arbitrary (AdditionalProperties schema) where+  arbitrary = oneof [ AdditionalPropertiesBool <$> arbitrary+                    , AdditionalPropertiesObject <$> arbitrary+                    ]++additionalProperties+  :: forall err schema.+     (schema -> Value -> [Failure err])+  -> AdditionalProperties schema+  -> HashMap Text Value+  -> [Failure (AdditionalPropertiesFailure err)]+additionalProperties _ (AdditionalPropertiesBool False) x+  | H.size x > 0 = pure $ Failure APBoolFailure (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+            . addToPath (P.Token k)+          <$> f schema v

@@ -0,0 +1,29 @@++module Data.Validator.Draft4.String where++import           Data.Aeson+import qualified Data.Text              as T+import           Text.RegexPR++import           Data.Validator.Failure+import           Import++-- | The spec requires "maxLength" to be non-negative.+maxLength :: Int -> Text -> Maybe (Failure ())+maxLength n x+  | n <= 0         = Nothing+  | T.length x > n = Just (Failure () (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)+  | 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

@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Validator.Failure where++import qualified Data.Aeson.Pointer as P++import           Import++-- For GHCs before 7.10:+import           Prelude            hiding (concat, sequence)++-- | Validators shouldn't know more about the schema they're going to+-- be used with than necessary. If a validator throws errors using the+-- error sum type of a particular schema, then it can't be used with+-- other schemas later that have different error sum types (at least not+-- without writing partial functions).+--+-- Thus validators that can only fail in one way return 'FailureInfo's.+-- Validators that can fail in multiple ways return 'ValidationFailure's+-- along with an custom error sum type for that particular validator.+--+-- It's the job of a schema's validate function to unify the errors produced+-- 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+  } deriving (Eq, Show)++setFailure :: b -> Failure a -> Failure b+setFailure e (Failure _ a b) = Failure e a b++modFailure :: (a -> b) -> Failure a -> Failure b+modFailure f v@(Failure a _ _) = v { _failureValidatorsCalled = f a }++addToPath :: P.Token -> Failure a -> Failure a+addToPath tok v@(Failure _ _ a) = v { _failureOffendingData = addToken a }+  where+    addToken :: P.Pointer -> P.Pointer+    addToken (P.Pointer ts) = P.Pointer (ts <> pure tok)

@@ -0,0 +1,67 @@++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           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++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+  -> schema+  -> Maybe schema+resolveFragment Nothing schema        = Just schema+resolveFragment (Just pointer) schema = do+  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer+  p <- either (const Nothing) Just (P.unescape urlDecoded)+  x <- either (const Nothing) Just (P.resolve p (toJSON schema))+  case fromJSON x of+    Error _         -> Nothing+    Success schema' -> Just schema'++--------------------------------------------------+-- * Internal+--------------------------------------------------++baseAndFragment :: Text -> URIBaseAndFragment+baseAndFragment = f . T.splitOn "#"+  where+    f :: [Text] -> URIBaseAndFragment+    f [x]   = (g x, Nothing)+    f [x,y] = (g x, g y)+    f _     = (Nothing, Nothing)++    g "" = Nothing+    g x  = Just x++resolveScopeAgainst :: Maybe Text -> Text -> Text+resolveScopeAgainst Nothing t = t+resolveScopeAgainst (Just scope) t+  | isRemoteReference t = t+  | otherwise           = smartAppend+  where+    -- There shouldn't be a fragment at the end of a scope URI,+    -- 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

@@ -0,0 +1,122 @@++module Data.Validator.Utils where++import           Control.Arrow+import qualified Data.HashMap.Strict  as H+import           Data.List.NonEmpty   (NonEmpty)+import qualified Data.List.NonEmpty   as N+import           Data.Scientific      (Scientific, fromFloatDigits)+import           Data.Set             (Set)+import qualified Data.Set             as S+import qualified Data.Text            as T+import qualified Data.Vector          as V++import           Import++--------------------------------------------------+-- * QuickCheck+--------------------------------------------------++arbitraryText :: Gen Text+arbitraryText = T.pack <$> arbitrary++arbitraryScientific :: Gen Scientific+arbitraryScientific = (fromFloatDigits :: Double -> Scientific) <$> arbitrary++arbitraryPositiveScientific :: Gen Scientific+arbitraryPositiveScientific = (fromFloatDigits :: Double -> Scientific)+                            . getPositive+                          <$> arbitrary++arbitraryValue :: Gen Value+arbitraryValue = sized f+  where+    f :: Int -> Gen Value+    f n | n <= 1    = oneof nonRecursive+        | otherwise = oneof $+            fmap (Array . V.fromList) (traverse (const (f (n `div` 10)))+              =<< (arbitrary :: Gen [()]))+          : fmap (Object . H.fromList) (traverse (const (g (n `div` 10)))+              =<< (arbitrary :: Gen [()]))+          : nonRecursive++    g :: Int -> Gen (Text, Value)+    g n = (,) <$> arbitraryText <*> f n++    nonRecursive :: [Gen Value]+    nonRecursive =+      [ pure Null+      , Bool <$> arbitrary+      , String <$> arbitraryText+      , Number <$> arbitraryScientific+      ]++arbitraryHashMap :: Arbitrary a => Gen (HashMap Text a)+arbitraryHashMap = H.fromList . fmap (first T.pack) <$> arbitrary++arbitrarySetOfText :: Gen (Set Text)+arbitrarySetOfText = S.fromList . fmap T.pack <$> arbitrary++newtype NonEmpty' a = NonEmpty' { _unNonEmpty' :: NonEmpty a }++instance FromJSON a => FromJSON (NonEmpty' a) where+  parseJSON v = do+    xs <- parseJSON v+    case N.nonEmpty xs of+      Nothing -> fail "Must have at least one item."+      Just ne -> pure (NonEmpty' ne)++instance ToJSON a => ToJSON (NonEmpty' a) where+  toJSON = toJSON . N.toList . _unNonEmpty'++instance Arbitrary a => Arbitrary (NonEmpty' a) where+  arbitrary = do+    xs <- arbitrary+    case N.nonEmpty xs of+      Nothing -> NonEmpty' . pure <$> arbitrary+      Just ne -> pure (NonEmpty' ne)++--------------------------------------------------+-- * allUniqueValues+--------------------------------------------------++allUniqueValues :: Vector Value -> Bool+allUniqueValues = allUnique . fmap OrdValue . V.toList++-- NOTE: When we no longer support GHC 7.8 we can generalize+-- allUnique to work on any Foldable and remove this function.+allUniqueValues' :: NonEmpty Value -> Bool+allUniqueValues' = allUnique . fmap OrdValue . N.toList++allUnique :: (Ord a) => [a] -> Bool+allUnique xs = S.size (S.fromList xs) == length xs++-- | OrdValue's Ord instance needs benchmarking, but it allows us to+-- use our 'allUnique' function instead of O(n^2) nub, so it's probably+-- worth it.+newtype OrdValue = OrdValue { _unOrdValue :: 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)

@@ -9,3 +9,4 @@ import           Data.Text           as Export (Text) import           Data.Traversable    as Export import           Data.Vector         as Export (Vector)+import           Test.QuickCheck     as Export hiding (Failure, Result, Success)

@@ -1,113 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Lib 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.JsonSchema-import           Data.Monoid-import           Data.Text                      (Text)-import qualified Data.Text                      as T-import           System.FilePath                ((</>))-import           Test.Framework                 (Test)-import           Test.Framework.Providers.HUnit (testCase)-import           Test.HUnit                     hiding (Test)--isLocal :: String -> Bool-isLocal file = (file /= "definitions.json")-            && (file /= "ref.json")-            && (file /= "refRemote.json")--data SchemaTest = SchemaTest-  { _stDescription :: Text-  , _stSchema      :: RawSchema-  , _stCases       :: [SchemaTestCase]-  }--data SchemaTestCase = SchemaTestCase-  { _scDescription :: Text-  , _scData        :: Value-  , _scValid       :: Bool-  }--instance FromJSON RawSchema where-  parseJSON = withObject "Schema" $ return . RawSchema Nothing--instance FromJSON SchemaTest where-  parseJSON = withObject "SchemaTest" $ \o -> SchemaTest-    <$> o .: "description"-    <*> o .: "schema"-    <*> o .: "tests" -- I wish this were "cases"--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 -> return $ 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 -> Test-toTest st =-  testCase (T.unpack $ _stDescription st) $ do-    sanityCheckTest (_stSchema st)-    forM_ (_stCases st) $ \sc -> do-      g <- assertRight =<< fetchReferencedSchemas draft4 mempty (_stSchema st)-      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 -> [ValidationFailure Draft4Failure] -> Assertion-assertValid _ [] = return ()-assertValid sc errs =-  assertFailure $ unlines-    [ "    Failed to validate data"-    , "    Description: "         <> T.unpack (_scDescription sc)-    , "    Data: "                <> show (_scData sc)-    , "    Validation failures: " <> show errs-    ]--assertInvalid :: SchemaTestCase -> [ValidationFailure Draft4Failure] -> Assertion-assertInvalid sc [] =-  assertFailure $ unlines-    [ "    Validated invalid data"-    , "    Description: " <> T.unpack (_scDescription sc)-    , "    Data: "        <> show (_scData sc)-    ]-assertInvalid _ _ = return ()--assertRight :: (Show a) => Either a b -> IO b-assertRight a =-  case a of-    Left e  -> assertFailure (show e) >> fail "assertRight failed"-    Right b -> return b--$(deriveFromJSON defaultOptions { fieldLabelModifier = map toLower . drop 3 } ''SchemaTestCase)

@@ -1,18 +1,76 @@+ module Main where  import           Control.Applicative-import           Data.List           (isSuffixOf)-import           Lib-import           System.Directory    (getDirectoryContents)-import           Test.Framework+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+  filenames <- filter isLocal . filter (".json" `isSuffixOf`) <$> getDirectoryContents dir   ts <- readSchemaTests dir filenames-  defaultMain (toTest <$> ts)+  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-    dir :: String-    dir = "JSON-Schema-Test-Suite/tests/draft4"+    [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+      }

@@ -3,21 +3,24 @@ import           Control.Applicative import           Control.Concurrent.Async       (withAsync) import           Data.List                      (isSuffixOf)-import           Lib import           Network.Wai.Application.Static (defaultFileServerSettings,                                                  staticApp) import           Network.Wai.Handler.Warp       (run) import           System.Directory               (getDirectoryContents)-import           Test.Framework+import           Test.Tasty                     (defaultMain, testGroup) +import           Shared                         (isLocal, readSchemaTests,+                                                 toTest)++dir :: String+dir = "JSON-Schema-Test-Suite/tests/draft4"+ main :: IO ()-main =-  withAsync (run 1234 $ staticApp $ defaultFileServerSettings "JSON-Schema-Test-Suite/remotes") $ \_ -> do-    filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)+main = withAsync serve $ \_ -> do+  filenames <- filter (not . isLocal) . filter (".json" `isSuffixOf`)                  <$> getDirectoryContents dir-    ts <- readSchemaTests dir filenames-    defaultMain (toTest <$> ts)+  ts <- readSchemaTests dir filenames+  defaultMain . testGroup "Tests that run an HTTP server" $ toTest <$> ts -  where-    dir :: String-    dir = "JSON-Schema-Test-Suite/tests/draft4"+serve :: IO ()+serve = run 1234 . staticApp . defaultFileServerSettings $ "JSON-Schema-Test-Suite/remotes"

@@ -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.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