hjsonschema 0.7.1.0 → 0.8.0.0

raw patch · 15 files changed

+311/−204 lines, 15 filesdep ~HUnitdep ~aesondep ~directoryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HUnit, aeson, directory, filepath, http-types, test-framework, test-framework-hunit, unordered-containers

API changes (from Hackage documentation)

Files

• Example.hs +68/−40
• README.md +41/−13
• changelog.txt +11/−0
• hjsonschema.cabal +19/−21
• src/Data/JsonSchema.hs +43/−37
• src/Data/JsonSchema/Core.hs +20/−13
• src/Data/JsonSchema/Draft4.hs +4/−2
• src/Data/JsonSchema/Draft4/Any.hs +14/−17
• src/Data/JsonSchema/Draft4/Arrays.hs +17/−8
• src/Data/JsonSchema/Draft4/Numbers.hs +2/−2
• src/Data/JsonSchema/Draft4/Objects.hs +1/−1
• src/Data/JsonSchema/Draft4/Objects/Properties.hs +7/−10
• src/Data/JsonSchema/Helpers.hs +7/−7
• src/Data/JsonSchema/Reference.hs +55/−29
• tests/Lib.hs +2/−4

@@ -13,14 +13,24 @@  import qualified Data.JsonSchema as JS --- Data.JsonSchema isn't designed to be imported qualified,--- but we're doing it here to make it obvious what's coming--- from the lib.+-- 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    = ""-  , JS._rsObject = schemaJSON+  { 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@@ -29,47 +39,65 @@ badData :: Value badData = Array $ V.fromList ["foo", "foo"] -main :: IO ()-main = do+--------------------------------------------------+-- * 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-  newSchemaCache <- (<> currentSchemaCache) <$> fetchGraph schemaData+  schemaGraph <- fetchGraph currentSchemaCache schemaData -  schema <- compileSchema newSchemaCache 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--    -- Not necessary in this case, but it serves as an example.-    ---    -- Note that Graphs are used to handle internal as well as external references.-    -- So even if a schema doesn't reference outside documents, you still need-    -- to generate a real Graph (and not just use mempty) if it refences itself.-    fetchGraph :: JS.RawSchema -> IO JS.Graph-    fetchGraph rs = do-      eitherGraph <- JS.fetchReferencedSchemas JS.draft4 rs H.empty+    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 graph -> return graph+        Left e  -> error $ "Failed to fetch graph with error: " <> T.unpack e+        Right g -> return g -    compileSchema :: JS.Graph -> JS.RawSchema -> IO (JS.Schema JS.Draft4Failure)-    compileSchema graph rs =-      case JS.compileDraft4 graph rs of-        Left failure -> error $ "Not a valid schema: " <> show failure-        Right schema -> return schema+--------------------------------------------------+-- * Helper Functions+-------------------------------------------------- -    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+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

@@ -1,27 +1,55 @@-# Intro+![hjsonschema logo](./logo.jpg) -An implementation of [JSON Schema](http://json-schema.org/) Draft 4 in haskell.+A Haskell implementation of the current [JSON Schema](http://json-schema.org/) specification (Draft 4). -# Status+[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) -Still in development. Lacks solid code to handle changing resolution scope.+# Example -Also note that hjsonschema uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for the "pattern" validator. This isn't compatible with the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.+See [Example.hs on GitHub](https://github.com/seagreen/hjsonschema/blob/master/Example.hs). -# Example+# Tests -See [Example.hs](./Example.hs).+## Install -# Install Tests+`git submodule update --init` -    git submodule update --init+## Run -# Notes+Will run self-contained: +`cabal test local`++Will start an HTTP server temporarily on port 1234:++`cabal test remote`++# Details++## Goals+++ Be a correct and fast implementation of the spec.+++ Be a useful reference for implementers in other languages. Haskell's high level nature, expressive type system and referential transparency suit this purpose well.++## Good Parts+++ Passes all the tests in the [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite).+++ Very modular, which should make it easy to support future versions of the specification.++## Bad Parts+++ Uses the [regexpr](https://hackage.haskell.org/package/regexpr-0.5.4) regular expression library for the "pattern" validator. It should use a library based on the ECMA 262 regex dialect, which the [spec](http://json-schema.org/latest/json-schema-validation.html#anchor33) requires.++## Notes+ + `draft4.json` is from commit # cc8ec81ce0abe2385ebd6c2a6f2d6deb646f874a [here](https://github.com/json-schema/json-schema). -# Credits+## Credits -Thanks to [Julian Berman](https://github.com/Julian) for the fantastic test suite.+[TJ Weigel](http://tjweigel.com/) created the logo. -Also thanks to Tim Baumann for his [aeson-schema](https://hackage.haskell.org/package/aeson-schema) library. Hjsonschema's test code and its implementation of `Graph` both originally came from there.+[Tim Baumann](https://github.com/timjb) wrote [aeson-schema](https://hackage.haskell.org/package/aeson-schema), on which hjsonschema's test code and its implementation of `SchemaGraph` were based.++[Julian Berman](https://github.com/Julian) maintains the fantastic [language agnostic test suite](https://github.com/json-schema/JSON-Schema-Test-Suite).

@@ -1,3 +1,14 @@+# 0.8+++ Improve scope updating and resolving.++ Rename RawSchema's _rsObject field to _rsData.++ Make RawSchema's _rsURI field a Maybe. This way schemas without a starting+URI can say so explicitly with Nothing instead of with "".++ Rename Graph to SchemaGraph. Declare it with data instead of type. Give it a+field referencing the starting schema. This field is used to find the curent+schema if no URI is in scope and a self-referencing $ref is found (e.g. "#").++ Change the order of the last two arguments to fetchReferencedSchemas.+ # 0.7.1  + Support GHC 7.8 again.

@@ -1,5 +1,5 @@ name:                   hjsonschema-version:                0.7.1.0+version:                0.8.0.0 synopsis:               JSON Schema library homepage:               https://github.com/seagreen/hjsonschema license:                MIT@@ -35,7 +35,7 @@                         OverloadedStrings   other-extensions:     TemplateHaskell   ghc-options:          -Wall-  build-depends:        aeson                >= 0.7   && < 0.10+  build-depends:        aeson                >= 0.7   && < 0.11                         -- 4.6 doesn't have a Traversable Either instance:                       , base                 >= 4.7   && < 4.9                       , bytestring           >= 0.10  && < 0.11@@ -44,7 +44,7 @@                       , hashable             >= 1.2   && < 1.3                       , hjsonpointer         >= 0.2   && < 0.3                       , http-client          >= 0.4.9 && < 0.5-                      , http-types           >= 0.8   && < 0.9+                      , http-types           >= 0.8   && < 0.10                       , mtl                  >= 2.2.1 && < 2.3                       , regexpr              >= 0.5   && < 0.6                       , scientific           >= 0.3   && < 0.4@@ -53,17 +53,6 @@                       , text                 >= 1.2   && < 1.3                       , vector               >= 0.10  && < 0.12 -executable example-  main-is:              Example.hs-  default-language:     Haskell2010-  ghc-options:          -Wall-  build-depends:        aeson-                      , base-                      , hjsonschema-                      , text-                      , unordered-containers-                      , vector- test-suite local   type:                 exitcode-stdio-1.0   hs-source-dirs:       tests@@ -76,7 +65,6 @@                       , base                       , bytestring                       , hjsonschema-                      , unordered-containers                       , text                       , vector                       , directory            >= 1.2 && < 1.3@@ -98,16 +86,26 @@                       , base                       , bytestring                       , hjsonschema-                      , unordered-containers                       , text                       , vector-                      , directory            >= 1.2 && < 1.3-                      , filepath             >= 1.3 && < 1.4-                      , HUnit                >= 1.2 && < 1.3-                      , test-framework       >= 0.8 && < 0.9-                      , test-framework-hunit >= 0.3 && < 0.4+                      , directory+                      , filepath+                      , HUnit+                      , test-framework+                      , test-framework-hunit                       , wai-app-static                       , warp++executable example+  main-is:              Example.hs+  default-language:     Haskell2010+  ghc-options:          -Wall+  build-depends:        aeson+                      , base+                      , hjsonschema+                      , text+                      , unordered-containers+                      , vector  source-repository head   type:               git

@@ -8,14 +8,11 @@   , 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 qualified Data.Text as T-import qualified Data.Vector as V  import           Data.JsonSchema.Core import           Data.JsonSchema.Draft4@@ -24,57 +21,66 @@ import           Import  -- For GHCs before 7.10:-import           Prelude hiding (sequence)+import           Prelude hiding (concat, sequence)  -- | Take a schema. Retrieve every document either it or its--- subschemas include via the "$ref" keyword. Load a 'Graph' out+-- subschemas include via the "$ref" keyword. Load a 'SchemaGraph' out -- with them.------ TODO: This function's URL processing is hacky and needs improvement.-fetchReferencedSchemas :: Spec err -> RawSchema -> Graph -> IO (Either Text Graph)+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 URLs.+-- 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-  -> Graph-  -> m (e Graph)-fetchReferencedSchemas' fetchRef spec rawSchema graph =-  let startingGraph = H.insert (_rsURI rawSchema) (_rsObject rawSchema) graph-  in foldlM (modFetch fetch) (return startingGraph) (includeSubschemas rawSchema)+  -> 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-    includeSubschemas :: RawSchema -> Vector RawSchema+    -- TODO: use a fold here+    includeSubschemas :: RawSchema -> [RawSchema]     includeSubschemas r =-      let newId = newResolutionScope (_rsURI r) (_rsObject r)-          xs = H.intersectionWith (\(ValSpec f _) x -> f newId x) (_unSpec spec) (_rsObject r)-          ys = V.concat . H.elems $ xs -- TODO: optimize-      in V.cons r . V.concat . V.toList $ includeSubschemas <$> ys--    modFetch :: (Graph -> RawSchema -> m (e Graph)) -> e Graph -> RawSchema -> m (e Graph)-    modFetch f eg rs = join <$> sequence (flip f rs <$> eg)+      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 :: Graph -> RawSchema -> m (e Graph)-    fetch g r =-      case H.lookup "$ref" (_rsObject r) >>= HE.toTxt >>= refAndPointer of-        Nothing     -> return (return g)-        Just (s, _) ->-          let url = (_rsURI r `combineIdAndRef` s)-          in if T.length url <= 0 || H.member url g || not ("://" `T.isInfixOf` url)-            then return (return g)-            else modDec (decodeResponse url) =<< fetchRef url+    fetch :: e SchemaCache -> RawSchema -> m (e SchemaCache)+    fetch eg r = join <$> sequence (run <$> eg)       where-        decodeResponse :: Text -> LBS.ByteString -> m (e Graph)-        decodeResponse url bts =+        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 -> fetchReferencedSchemas' fetchRef spec (RawSchema url obj) g--        modDec :: (LBS.ByteString -> m (e Graph)) -> e LBS.ByteString -> m (e Graph)-        modDec f eBts = join <$> sequence (f <$> eBts)+            Right obj -> fmap _cachedSchemas <$> fetchReferencedSchemas' fetchRef spec g (RawSchema (Just uri) obj)

@@ -15,7 +15,7 @@ -- * Primary API -------------------------------------------------- -compile :: forall err. Spec err -> Graph -> RawSchema -> Schema err+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@@ -35,15 +35,22 @@ newtype Schema err = Schema { _unSchema :: [Value -> [ValidationFailure err]] }  data RawSchema = RawSchema-  { _rsURI    :: Text-  , _rsObject :: HashMap Text Value-  }+  { _rsURI  :: !(Maybe Text)+  -- ^ NOTE: Must not include a URI fragment.+  , _rsData :: !(HashMap Text Value)+  } deriving (Show) --- | A mapping of URLs to schemas.+-- | A set of RawSchemas, split into a HashMap. ----- Each key/value pair provides the components of a RawSchema.-type Graph = HashMap Text (HashMap Text Value)+-- Keys correspond to Schema _rsURIs. Values correspond to Schema _rsObjects.+type SchemaCache = HashMap Text (HashMap Text Value) +data SchemaGraph = SchemaGraph+  { _startingSchema :: !RawSchema+  -- ^ The schema initially referenced by '#'.+  , _cachedSchemas  :: !SchemaCache+  } deriving (Show)+ -------------------------------------------------- -- * Validators --------------------------------------------------@@ -55,7 +62,7 @@ -- 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 = Text -> Value -> Vector RawSchema+type EmbeddedSchemas = Maybe Text -> Value -> [RawSchema]  -- | This is what's used to write most validators in practice. --@@ -68,17 +75,17 @@ -- and modifyName for this purpose. type ValidatorConstructor schemaErr valErr    = Spec schemaErr-  -> Graph+  -> SchemaGraph   -> RawSchema   -> Value   -> Maybe (Value -> valErr)  data ValidationFailure err = ValidationFailure-  { _failureName :: err-  , _failureInfo :: FailureInfo+  { _failureName :: !err+  , _failureInfo :: !FailureInfo   } deriving (Show)  data FailureInfo = FailureInfo-  { _validatingData :: Value-  , _offendingData  :: Value+  { _validatingData :: !Value+  , _offendingData  :: !Value   } deriving (Show)

@@ -123,7 +123,9 @@ isValidSchema r =   case decode . LBS.fromStrict $ $(embedFile "draft4.json") of     Nothing -> error "Schema decode failed (this should never happen)"-    Just s  -> validate (compile draft4 H.empty $ RawSchema "" s) $ Object (_rsObject r)+    Just s  ->+      let a = RawSchema Nothing s+      in validate (compile draft4 (SchemaGraph a mempty) a) $ Object (_rsData r)  -- | Check that a 'RawSchema' conforms to the JSON Schema Draft 4 -- master schema document. Compile it if it does.@@ -133,7 +135,7 @@ -- -- NOTE: It's not actually required to run 'isValidSchema' on -- prospective draft 4 schemas at all.-compileDraft4 :: Graph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure)+compileDraft4 :: SchemaGraph -> RawSchema -> Either [ValidationFailure Draft4Failure] (Schema Draft4Failure) compileDraft4 g r =   case isValidSchema r of     []   -> Right (compile draft4 g r)

@@ -3,11 +3,9 @@  import           Control.Monad import qualified Data.HashMap.Strict       as H-import           Data.JsonPointer+import           Data.Maybe import           Data.Scientific-import           Data.Text.Encoding import qualified Data.Vector               as V-import           Network.HTTP.Types.URI  import           Data.JsonSchema.Core import           Data.JsonSchema.Helpers@@ -93,26 +91,25 @@  notValidator :: ValidatorConstructor err [FailureInfo] notValidator spec g s val@(Object o) = do-  let sub = compile spec g (RawSchema (_rsURI s) o)+  let subSchema = compile spec g $ RawSchema (_rsURI s) o   Just $ \x ->-    case validate sub x of+    case validate subSchema x of       [] -> pure (FailureInfo val x)       _  -> mempty notValidator _ _ _ _ = Nothing --- http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03+-- JSON Reference Draft Document: ----- TODO: Any members other than "$ref" in a JSON Reference object SHALL be--- ignored.+--      http://tools.ietf.org/html/draft-pbryan-zyp-json-ref-03 ref :: ValidatorConstructor err [ValidationFailure err] ref spec g s (String val) = do-  (reference, pointer) <- refAndPointer (_rsURI s `combineIdAndRef` val)-  r <- RawSchema reference <$> H.lookup reference g-  let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer-  p <- eitherToMaybe $ jsonPointer urlDecoded-  case resolvePointer p (Object $ _rsObject r) of-    Right (Object o) ->-      let compiled = compile spec g $ RawSchema (_rsURI r) o-      in Just $ validate compiled-    _ -> Nothing+  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

@@ -9,8 +9,15 @@ import           Data.JsonSchema.Helpers import           Import -data ItemsFailure err = Items err | AdditionalItemsBool | AdditionalItemsObject err+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) =@@ -22,36 +29,38 @@ items spec g s (Array vs) = do   os <- traverse toObj vs   let subSchemas = compile spec g . RawSchema (_rsURI s) <$> V.toList os-      mAdditionalItems = additionalItems spec g s =<< H.lookup "additionalItems" (_rsObject s)+      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 <> additionalItemFailures+        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 {}.------ TODO: Should have its own error type instead of sharing with Items.-additionalItems :: ValidatorConstructor err [ValidationFailure (ItemsFailure err)]+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 AdditionalItemsBool (FailureInfo val x)+          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 AdditionalItemsObject) . validate subSchema+      Array ys -> V.toList ys >>= fmap (modifyFailureName AdditionalObject) . validate subSchema       _        -> mempty additionalItems _ _ _ _ = Nothing 

@@ -37,7 +37,7 @@   where     checkExclusive :: (Scientific -> Scientific -> Bool, MaximumFailure)     checkExclusive =-      case H.lookup "exclusiveMaximum" (_rsObject s) of+      case H.lookup "exclusiveMaximum" (_rsData s) of         Just (Bool a) -> if a then ((>=), ExclusiveMaximum) else ((>), Maximum)         _             -> ((>), Maximum) maximumVal _ _ _ _ = Nothing@@ -55,7 +55,7 @@   where     checkExclusive :: (Scientific -> Scientific -> Bool, MinimumFailure)     checkExclusive =-      case H.lookup "exclusiveMinimum" (_rsObject s) of+      case H.lookup "exclusiveMinimum" (_rsData s) of         Just (Bool a) -> if a then ((<=), ExclusiveMinimum) else ((<), Minimum)         _             -> ((<), Minimum) minimumVal _ _ _ _ = Nothing

@@ -85,7 +85,7 @@         in schemaFailures <> propertyFailures       _ -> mempty   where-    toSchemaDep :: Spec a -> Graph -> (Text, Value) -> [(Text, Schema a)]+    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 

@@ -30,8 +30,8 @@ properties :: forall err. ValidatorConstructor err [ValidationFailure (PropertiesFailure err)] properties spec g s val = do   let mProps   = propertiesUnmatched val-      mPatProp = patternUnmatched spec g s =<< H.lookup "patternProperties" (_rsObject s)-      mAddProp = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)+      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@@ -61,12 +61,9 @@  patternProperties :: ValidatorConstructor err [ValidationFailure (PatternPropertiesFailure err)] patternProperties spec g s val = do-  when (H.member "properties" (_rsObject s)) Nothing+  when (H.member "properties" (_rsData s)) Nothing   let mPatternProps = patternUnmatched spec g s val-  -- TODO: checking additionalProperties as well doesn't help with tests.-  -- Make sure we're doing the correct thing, then get tests for this-  -- merged into the test suite.-  let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsObject s)+  let mAdditionalProps = runAdditionalProperties spec g s =<< H.lookup "additionalProperties" (_rsData s)   when (isNothing mPatternProps && isNothing mAdditionalProps) Nothing   Just $ \x ->     case x of@@ -78,7 +75,7 @@  patternUnmatched   :: Spec err-  -> Graph+  -> SchemaGraph   -> RawSchema   -> Value   -> Maybe (Value -> ([ValidationFailure err], Value))@@ -122,8 +119,8 @@  additionalProperties :: ValidatorConstructor err [ValidationFailure (AdditionalPropertiesFailure err)] additionalProperties spec g s val = do-  when (H.member "properties" (_rsObject s)) Nothing-  when (H.member "patternProperties" (_rsObject s)) Nothing+  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.

@@ -1,3 +1,4 @@+ module Data.JsonSchema.Helpers where  import           Control.Exception@@ -24,7 +25,7 @@ objEmbed _ _ = mempty  arrayEmbed :: EmbeddedSchemas-arrayEmbed t (Array vs) = objEmbed t =<< vs+arrayEmbed t (Array vs) = objEmbed t =<< V.toList vs arrayEmbed _ _ = mempty  objOrArrayEmbed :: EmbeddedSchemas@@ -33,28 +34,27 @@ objOrArrayEmbed _ _ = mempty  objMembersEmbed :: EmbeddedSchemas-objMembersEmbed t (Object o) = objEmbed t =<< V.fromList (H.elems o)+objMembersEmbed t (Object o) = objEmbed t =<< H.elems o objMembersEmbed _ _ = mempty  -------------------------------------------------- -- * Modify Validators for use in Specs -------------------------------------------------- --- | TODO: Is there something easier to replace these fmaps with? giveName   :: forall err. err   -> ValidatorConstructor err [FailureInfo]   -> ValidatorConstructor err [ValidationFailure err]-giveName err = (fmap.fmap.fmap.fmap.fmap.fmap.fmap) (ValidationFailure err)+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 = (fmap.fmap.fmap.fmap.fmap.fmap.fmap) f+modifyName failureHandler f spec g rs v = (fmap.fmap) modErr <$> f spec g rs v   where-    f :: ValidationFailure valErr -> ValidationFailure schemaErr-    f (ValidationFailure a b) = ValidationFailure (failureHandler a) b+    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

@@ -1,39 +1,65 @@--- | TODO: The code handling resolution scope updates--- is hacky and needs improvement.  module Data.JsonSchema.Reference where -import qualified Data.HashMap.Strict as H-import qualified Data.Text           as T+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 -combineIdAndRef :: Text -> Text -> Text-combineIdAndRef a b-  | "://" `T.isInfixOf` b              = b-  | T.length a < 1 || T.length b < 1   = a <> b-  | T.last a == '#' && T.head b == '#' = a <> T.tail b-  | otherwise                          = a <> b--combineIds :: Text -> Text -> Text-combineIds a b-  | b == "#" || b == ""                = a-  | "://" `T.isInfixOf` b              = b-  | T.length a < 1 || T.length b < 1   = a <> b-  | T.last a == '#' && T.head b == '#' = a <> T.tail b-  | otherwise                          = a <> b+type URIBase = Maybe Text+type URIBaseAndFragment = (Maybe Text, Maybe Text) -newResolutionScope :: Text -> HashMap Text Value -> Text-newResolutionScope t o =+newResolutionScope :: URIBase -> HashMap Text Value -> URIBase+newResolutionScope mScope o =   case H.lookup "id" o of-    Just (String idKeyword) -> t `combineIds` idKeyword-    _                       -> t+    Just (String t) -> fst . baseAndFragment $ resolveScopeAgainst mScope t+    _               -> mScope -refAndPointer :: Text -> Maybe (Text, Text)-refAndPointer val = getParts $ T.splitOn "#" val+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-    getParts :: [Text] -> Maybe (Text, Text)-    getParts []    = Just ("","")-    getParts [x]   = Just (x,"")-    getParts [x,y] = Just (x,y)-    getParts _     = Nothing+    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

@@ -9,7 +9,6 @@ import           Data.Aeson.TH import qualified Data.ByteString.Lazy           as LBS import           Data.Char                      (toLower)-import qualified Data.HashMap.Strict            as H import           Data.JsonSchema import           Data.Monoid import           Data.Text                      (Text)@@ -37,8 +36,7 @@   }  instance FromJSON RawSchema where-  parseJSON = withObject "Schema" $ \o ->-    return RawSchema { _rsURI = "", _rsObject = o }+  parseJSON = withObject "Schema" $ return . RawSchema Nothing  instance FromJSON SchemaTest where   parseJSON = withObject "SchemaTest" $ \o -> SchemaTest@@ -71,7 +69,7 @@   testCase (T.unpack $ _stDescription st) $ do     sanityCheckTest (_stSchema st)     forM_ (_stCases st) $ \sc -> do-      g <- assertRight =<< fetchReferencedSchemas draft4 (_stSchema st) H.empty+      g <- assertRight =<< fetchReferencedSchemas draft4 mempty (_stSchema st)       let res = validate (compile draft4 g $ _stSchema st) (_scData sc)       if _scValid sc         then assertValid   sc res