git.iko.soy/typeable/hjsonschema
on master help sign in
swap
bd8cdfc3 ahead, 0 behind
4 files changed+40−18
since splitsnapshots
unifiedsplit
.travis.yml−3 changelog.md+6 hjsonschema.cabal+2−7 src/JSONSchema/Validator/Draft4/Any.hs+32−8
.travis.yml−3
@@ -26,9 +26,6 @@ before_cache:
2626
2727matrix:
2828 include:
29− - compiler: "ghc-7.10.3"
30− # env: TEST=--disable-tests BENCH=--disable-benchmarks
31− addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}
3229 - compiler: "ghc-8.0.2"
3330 # env: TEST=--disable-tests BENCH=--disable-benchmarks
3431 addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
changelog.md+6
@@ -1,5 +1,11 @@
11# 1.8.0
22
3++ Add GHC 8.4 support (thanks @4e6 !).
4++ Drop GHC 7.10 support.
5++ Fix JSON Pointer resolution error.
6+
7+# 1.8.0
8+
39+ Allow HTTPS references (thanks @creichert!).
410+ Use `safe-exceptions` to eliminate the risk of catching asynchronous exceptions.
511
hjsonschema.cabal+2−7
@@ -1,5 +1,5 @@
11name: hjsonschema
2−version: 1.8.0
2+version: 1.9.0
33synopsis: JSON Schema library
44homepage: https://github.com/seagreen/hjsonschema
55license: MIT
@@ -10,7 +10,7 @@ category: Data
1010build-type: Simple
1111cabal-version: >=1.10
1212-- Rerun multi-ghc-travis (executable make-travis-yml-2) after changing:
13−Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1
13+Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1
1414extra-source-files:
1515 changelog.md
1616 JSON-Schema-Test-Suite/remotes/*.json
@@ -77,12 +77,9 @@ library
7777 , QuickCheck >= 2.8
7878 , safe-exceptions >= 0.1.6
7979 , scientific >= 0.3
80− , semigroups >= 0.18
8180 , unordered-containers >= 0.2
8281 , text >= 1.1
8382 , vector >= 0.10
84− if impl(ghc < 8.0)
85− build-depends: semigroups == 0.18.*
8683
8784test-suite local
8885 hs-source-dirs:
@@ -117,7 +114,6 @@ test-suite local
117114 , hjsonschema
118115 , profunctors
119116 , protolude
120− , semigroups
121117 , text
122118 , QuickCheck
123119 , unordered-containers
@@ -156,7 +152,6 @@ test-suite remote
156152 , hjsonschema
157153 , profunctors
158154 , protolude
159− , semigroups
160155 , text
161156 , unordered-containers
162157 , vector
src/JSONSchema/Validator/Draft4/Any.hs+32−8
@@ -4,6 +4,7 @@ import Import hiding ((<>))
44
55import Data.Aeson.TH (constructorTagModifier)
66import Data.Char (toLower)
7+import qualified Data.HashMap.Strict as HM
78import Data.List.NonEmpty (NonEmpty((:|)))
89import qualified Data.List.NonEmpty as NE
910import qualified Data.Scientific as SCI
@@ -133,7 +134,7 @@ data JSONPointerError
133134 deriving (Eq, Show)
134135
135136resolveFragment
136− :: forall schema. (FromJSON schema, ToJSON schema)
137+ :: (FromJSON schema, ToJSON schema)
137138 => (BaseURI -> schema -> BaseURI)
138139 -> Scope schema
139140 -> Text
@@ -158,17 +159,40 @@ resolveFragment updateScope scope fragment = do
158159 -- as property keys that aren't meant to change scope?
159160 -- Perhaps this should be added to the language agnostic
160161 -- test suite as well.
162+ --
163+ -- In the meantime 'newBaseURIFromFragment' drops all keys
164+ -- from JSON objects except "id", which at least prevents
165+ -- SubschemaDecodingError in a situation where one of the
166+ -- values we step through isn't a valid schema.
161167 go :: (Value, BaseURI)
162168 -> JP.Token
163169 -> Either JSONPointerError (Value, BaseURI)
164− go (lastVal, uri) tok = do
170+ go (lastVal, baseURI) tok = do
165171 v <- first ResolutionError (JP.resolveToken tok lastVal)
166− case v of
167− Array _ -> pure (v, uri)
168− _ -> do
169− -- PERFORMANCE: Avoid deserializing subschemas.
170− schema <- first SubschemaDecodingError (fromJSONEither v)
171− pure (v, updateScope uri schema)
172+ newBase <- newBaseURIFromFragment updateScope baseURI v
173+ Right (v, newBase)
174+
175+-- | Update the 'BaseURI' (the store of the current "id" value)
176+-- after resolving one token of a JSON Pointer and stepping into
177+-- a new 'Value'.
178+newBaseURIFromFragment
179+ :: FromJSON schema
180+ => (BaseURI -> schema -> BaseURI)
181+ -> BaseURI
182+ -> Value
183+ -> Either JSONPointerError BaseURI
184+newBaseURIFromFragment updateScope baseURI v =
185+ case v of
186+ Object hm -> do
187+ let hmWithOnlyId = case HM.lookup idKey hm of
188+ Nothing -> mempty
189+ Just idVal -> HM.singleton idKey idVal
190+ schema <- first SubschemaDecodingError (fromJSONEither (Object hmWithOnlyId))
191+ Right (updateScope baseURI schema)
192+ _ -> Right baseURI
193+ where
194+ idKey :: Text
195+ idKey = "id"
172196
173197--------------------------------------------------
174198-- * enum