hjsonschema 1.8.0 → 1.10.0
raw patch · 10 files changed
Files
- README.md +8/−20
- changelog.md +10/−0
- hjsonschema.cabal +47/−5
- src/JSONSchema/Fetch.hs +2/−1
- src/JSONSchema/Validator/Draft4/Any.hs +32/−8
- src/JSONSchema/Validator/Draft4/String.hs +3/−5
- test/JSONSchema/Validator/Draft4/StringSpec.hs +25/−0
- test/Local.hs +2/−2
- test/Shared.hs +4/−4
- test/Spec.hs +1/−0
README.md view
@@ -1,37 +1,25 @@-# Summary--A Haskell implementation of [JSON Schema](http://json-schema.org/) ([Draft 4](http://json-schema.org/specification-links.html)).+# DEPRECATION NOTICE -[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema)+`hjsonschema` was an attempt to build a very modular JSON Schema library. Validators have [a concrete type](src/JSONSchema/Validator/Types.hs) and can be mixed and matched into new [Specs](src/JSONSchema/Types.hs). -# Example+However this flexibility came at the price of complicating the code. I don't think it was the right tradeoff, especially since situations where you'd want to change what validators make up a `Spec` at runtime seem rare. -See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs).+Also, there are many parts of JSON Schema that `hjsonschema` doesn't implement properly (as you can see from the issue tracker). I'm hoping that a new JSON Schema library will come along that handles these correctly. In the meantime I'm happy to merge working fixes into here. -# Design+# Links -`hjsonschema` was an attempt to build a very modular JSON Schema library. Validators have [a concrete type](src/JSONSchema/Validator/Types.hs) and can be mixed and matched into new [Specs](src/JSONSchema/Types.hs).+[Hackage](https://hackage.haskell.org/package/hjsonschema) / [GitHub](https://github.com/seagreen/hjsonschema) / [Travis CI](https://travis-ci.org/seagreen/hjsonschema) -However this flexibility comes at the price of complicating the code. I'm no longer sure it was the right tradeoff, especially since situations where you'd want to change what validators make up a `Spec` at runtime seem rare.+# Example -Also, there are edge cases of JSON Schema that `hjsonschema` doesn't implement properly (as you can see from the issue tracker). My motivation to fix them myself has ended. However, I'll still maintain the library, give feedback on issues, and merge PRs. I'd also be happy to advise any Haskellers who are interested in writing their own JSON Schema libraries.+See [here](https://github.com/seagreen/hjsonschema/blob/master/examples/Simple.hs). # System dependencies + Requires [pcre](http://www.pcre.org/) (`pkgs.pcre` in Nixpkgs). -# Tests--Run all: `stack test`--Run only local tests: `stack test hjsonschema:local`--Run only remote tests (temporarily starts an HTTP server on port 1234 and makes GETs to json-schema.org): `stack test hjsonschema:remote`- ## Vendoring + `JSON-Schema-Test-Suite` is vendored from commit # c1b12bf699f29a04b4286711c6e3bbfba66f21e5 [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite). + `src/draft4.json` is from commit # c1b12bf699f29a04b4286711c6e3bbfba66f21e5 [here](https://github.com/json-schema/json-schema). The [root ref in remote ref](./JSON-Schema-Test-Suite/tests/draft4/refRemote.json) test has been modified to fix [#175](https://github.com/json-schema-org/JSON-Schema-Test-Suite/issues/175).--+ `.travis.yml` was created with `make_travis_yml_2.hs` commit # ea6c7d177a97bfbfb2fdc4deba943d60d2aff199.
changelog.md view
@@ -1,3 +1,13 @@+# 1.10.0+++ String match fixes (thanks @sol !).++# 1.8.0+++ Add GHC 8.4 support (thanks @4e6 !).++ Drop GHC 7.10 support.++ Fix JSON Pointer resolution error.+ # 1.8.0 + Allow HTTPS references (thanks @creichert!).
hjsonschema.cabal view
@@ -1,5 +1,5 @@ name: hjsonschema-version: 1.8.0+version: 1.10.0 synopsis: JSON Schema library homepage: https://github.com/seagreen/hjsonschema license: MIT@@ -10,7 +10,7 @@ build-type: Simple cabal-version: >=1.10 -- Rerun multi-ghc-travis (executable make-travis-yml-2) after changing:-Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1+Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 extra-source-files: changelog.md JSON-Schema-Test-Suite/remotes/*.json@@ -77,11 +77,55 @@ , QuickCheck >= 2.8 , safe-exceptions >= 0.1.6 , scientific >= 0.3- , semigroups >= 0.18 , unordered-containers >= 0.2 , text >= 1.1 , vector >= 0.10 +test-suite spec+ hs-source-dirs:+ test+ src+ main-is: Spec.hs+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options:+ -Wall+ default-extensions:+ DeriveGeneric+ NoImplicitPrelude+ OverloadedStrings+ ScopedTypeVariables+ other-modules:+ Import+ JSONSchema.Validator.Draft4.String++ JSONSchema.Validator.Draft4.StringSpec+ build-depends:+ base >= 4.7 && < 5+ -- 0.11 is for `.:!`:+ , aeson >= 0.11+ , bytestring >= 0.10+ , containers >= 0.5+ , file-embed >= 0.0.8+ , filepath >= 1.3+ , hashable >= 1.2+ , hjsonpointer >= 1.1+ -- 0.4.30 is for parseUrlThrow:+ , http-client >= 0.4.30+ , http-client-tls >= 0.3+ , http-types >= 0.8+ , pcre-heavy >= 1.0+ , profunctors >= 5.0+ , protolude >= 0.1.10+ , QuickCheck >= 2.8+ , safe-exceptions >= 0.1.6+ , scientific >= 0.3+ , unordered-containers >= 0.2+ , text >= 1.1+ , vector >= 0.10++ , hspec >= 2.2+ test-suite local hs-source-dirs: test@@ -115,7 +159,6 @@ , hjsonschema , profunctors , protolude- , semigroups , text , QuickCheck , unordered-containers@@ -154,7 +197,6 @@ , hjsonschema , profunctors , protolude- , semigroups , text , unordered-containers , vector
src/JSONSchema/Fetch.hs view
@@ -7,6 +7,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HM+import qualified Data.Semigroup as S import qualified Data.Text as T import qualified Network.HTTP.Client as NC import qualified Network.HTTP.Client.TLS as NCTLS@@ -29,7 +30,7 @@ -- | Keys are URIs (without URI fragments). newtype URISchemaMap schema = URISchemaMap { _unURISchemaMap :: HashMap Text schema }- deriving (Eq, Show, Monoid)+ deriving (Eq, Show, S.Semigroup, Monoid) -- | A top-level schema along with its location. data SchemaWithURI schema = SchemaWithURI
src/JSONSchema/Validator/Draft4/Any.hs view
@@ -4,6 +4,7 @@ import Data.Aeson.TH (constructorTagModifier) import Data.Char (toLower)+import qualified Data.HashMap.Strict as HM import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE import qualified Data.Scientific as SCI@@ -133,7 +134,7 @@ deriving (Eq, Show) resolveFragment- :: forall schema. (FromJSON schema, ToJSON schema)+ :: (FromJSON schema, ToJSON schema) => (BaseURI -> schema -> BaseURI) -> Scope schema -> Text@@ -158,17 +159,40 @@ -- as property keys that aren't meant to change scope? -- Perhaps this should be added to the language agnostic -- test suite as well.+ --+ -- In the meantime 'newBaseURIFromFragment' drops all keys+ -- from JSON objects except "id", which at least prevents+ -- SubschemaDecodingError in a situation where one of the+ -- values we step through isn't a valid schema. go :: (Value, BaseURI) -> JP.Token -> Either JSONPointerError (Value, BaseURI)- go (lastVal, uri) tok = do+ go (lastVal, baseURI) tok = do v <- first ResolutionError (JP.resolveToken tok lastVal)- case v of- Array _ -> pure (v, uri)- _ -> do- -- PERFORMANCE: Avoid deserializing subschemas.- schema <- first SubschemaDecodingError (fromJSONEither v)- pure (v, updateScope uri schema)+ newBase <- newBaseURIFromFragment updateScope baseURI v+ Right (v, newBase)++-- | Update the 'BaseURI' (the store of the current "id" value)+-- after resolving one token of a JSON Pointer and stepping into+-- a new 'Value'.+newBaseURIFromFragment+ :: FromJSON schema+ => (BaseURI -> schema -> BaseURI)+ -> BaseURI+ -> Value+ -> Either JSONPointerError BaseURI+newBaseURIFromFragment updateScope baseURI v =+ case v of+ Object hm -> do+ let hmWithOnlyId = case HM.lookup idKey hm of+ Nothing -> mempty+ Just idVal -> HM.singleton idKey idVal+ schema <- first SubschemaDecodingError (fromJSONEither (Object hmWithOnlyId))+ Right (updateScope baseURI schema)+ _ -> Right baseURI+ where+ idKey :: Text+ idKey = "id" -------------------------------------------------- -- * enum
src/JSONSchema/Validator/Draft4/String.hs view
@@ -22,10 +22,8 @@ = MaxLengthInvalid MaxLength Text deriving (Eq, Show) --- | The spec requires @"maxLength"@ to be non-negative. maxLengthVal :: MaxLength -> Text -> Maybe MaxLengthInvalid maxLengthVal a@(MaxLength n) x- | n <= 0 = Nothing | T.length x > n = Just (MaxLengthInvalid a x) | otherwise = Nothing @@ -45,10 +43,8 @@ = MinLengthInvalid MinLength Text deriving (Eq, Show) --- | The spec requires @"minLength"@ to be non-negative. minLengthVal :: MinLength -> Text -> Maybe MinLengthInvalid minLengthVal a@(MinLength n) x- | n <= 0 = Nothing | T.length x < n = Just (MinLengthInvalid a x) | otherwise = Nothing @@ -73,6 +69,8 @@ patternVal a@(PatternValidator t) x = case RE.compileM (encodeUtf8 t) mempty of Left _ -> Just PatternNotRegex- Right re -> if x RE.=~ re+ Right re -> if input RE.=~ re then Nothing else Just (PatternInvalid a x)+ where+ input = T.unpack x -- workaround for a bug in pcre-light
+ test/JSONSchema/Validator/Draft4/StringSpec.hs view
@@ -0,0 +1,25 @@+module JSONSchema.Validator.Draft4.StringSpec (spec) where++import Protolude++import Test.Hspec++import JSONSchema.Validator.Draft4.String++spec :: Spec+spec = do+ describe "maxLengthVal" $ do+ context "with 0" $ do+ it "accepts the empty string" $ do+ maxLengthVal (MaxLength 0) "" `shouldBe` Nothing++ it "rejects other strings" $ do+ maxLengthVal (MaxLength 0) "foo" `shouldBe` Just (MaxLengthInvalid (MaxLength 0) "foo")++ describe "patternVal" $ do+ it "matches a substring" $ do+ patternVal (PatternValidator "baz") "foo bar baz" `shouldBe` Nothing++ context "with .*" $ do+ it "matches the empty string (test for workaround for a bug in pcre-light)" $ do+ patternVal (PatternValidator ".*") "" `shouldBe` Nothing
test/Local.hs view
@@ -62,7 +62,7 @@ Nothing -> expectationFailure "timeout expired" Just a -> pure a - validate :: D4.Schema -> SchemaTestCase -> Expectation+ validate :: HasCallStack => D4.Schema -> SchemaTestCase -> Expectation validate s sc = do res <- D4.fetchHTTPAndValidate (D4.SchemaWithURI s Nothing) (_scData sc) let failures = case res of@@ -72,7 +72,7 @@ <> show other) assertResult sc failures - validateExample :: JT.Schema -> SchemaTestCase -> Expectation+ validateExample :: HasCallStack => JT.Schema -> SchemaTestCase -> Expectation validateExample s sc = do res <- AlternateSchema.referencesViaHTTP (D4.SchemaWithURI s Nothing) case res of
@@ -14,7 +14,7 @@ import Test.Hspec skipTest :: FilePath -> Bool-skipTest file = (file == "optional/format.json") -- Optional+skipTest file = (file == "optional/format.json") || (file == "optional/zeroTerminatedFloats.json") || (file == "optional/ecmascript-regex.json") @@ -109,12 +109,12 @@ Error e -> panic ("Couldn't parse schema: " <> show e) Success a -> a -assertResult :: Show err => SchemaTestCase -> [err] -> Expectation+assertResult :: (HasCallStack, Show err) => SchemaTestCase -> [err] -> Expectation assertResult sc failures | _scValid sc = assertValid sc failures | otherwise = assertInvalid sc failures -assertValid :: Show err => SchemaTestCase -> [err] -> Expectation+assertValid :: (HasCallStack, Show err) => SchemaTestCase -> [err] -> Expectation assertValid _ [] = pure () assertValid sc failures = expectationFailure $ unlines@@ -124,7 +124,7 @@ , " Validation failures: " <> show failures ] -assertInvalid :: SchemaTestCase -> [err] -> Expectation+assertInvalid :: HasCallStack => SchemaTestCase -> [err] -> Expectation assertInvalid sc [] = expectationFailure $ unlines [ " Validated invalid data"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-discover #-}