2baee34..master · typeable/hjsonschema

git.iko.soy/typeable/hjsonschema

on master help sign in

.travis.yml−3

since splitsnapshots

unifiedsplit

@@ -26,9 +26,6 @@ before_cache:

27matrix:

28 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]}}

32 - compiler: "ghc-8.0.2"

29 - compiler: "ghc-8.0.2"

33 # env: TEST=--disable-tests BENCH=--disable-benchmarks

30 # env: TEST=--disable-tests BENCH=--disable-benchmarks

34 addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}

31 addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}

changelog.md+6

@@ -1,5 +1,11 @@

1# 1.8.0

3++ Add GHC 8.4 support (thanks @4e6 !).

4++ Drop GHC 7.10 support.

5++ Fix JSON Pointer resolution error.

7+# 1.8.0

3+ Allow HTTPS references (thanks @creichert!).

9+ Allow HTTPS references (thanks @creichert!).

4+ Use `safe-exceptions` to eliminate the risk of catching asynchronous exceptions.

10+ Use `safe-exceptions` to eliminate the risk of catching asynchronous exceptions.

hjsonschema.cabal+2−7

@@ -1,5 +1,5 @@

1name: hjsonschema

2−version: 1.8.0

2+version: 1.9.0

3synopsis: JSON Schema library

4homepage: https://github.com/seagreen/hjsonschema

5license: MIT

@@ -10,7 +10,7 @@ category: Data

10build-type: Simple

11cabal-version: >=1.10

12-- 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

14extra-source-files:

15 changelog.md

16 JSON-Schema-Test-Suite/remotes/*.json

@@ -77,12 +77,9 @@ library

77 , QuickCheck >= 2.8

78 , safe-exceptions >= 0.1.6

79 , scientific >= 0.3

80− , semigroups >= 0.18

81 , unordered-containers >= 0.2

80 , unordered-containers >= 0.2

82 , text >= 1.1

81 , text >= 1.1

83 , vector >= 0.10

82 , vector >= 0.10

84− if impl(ghc < 8.0)

85− build-depends: semigroups == 0.18.*

87test-suite local

84test-suite local

88 hs-source-dirs:

85 hs-source-dirs:

@@ -117,7 +114,6 @@ test-suite local

117 , hjsonschema

114 , hjsonschema

118 , profunctors

115 , profunctors

119 , protolude

116 , protolude

120− , semigroups

121 , text

117 , text

122 , QuickCheck

118 , QuickCheck

123 , unordered-containers

119 , unordered-containers

@@ -156,7 +152,6 @@ test-suite remote

156 , hjsonschema

152 , hjsonschema

157 , profunctors

153 , profunctors

158 , protolude

154 , protolude

159− , semigroups

160 , text

155 , text

161 , unordered-containers

156 , unordered-containers

162 , vector

157 , vector

src/JSONSchema/Validator/Draft4/Any.hs+32−8

@@ -4,6 +4,7 @@ import Import hiding ((<>))

5import Data.Aeson.TH (constructorTagModifier)

6import Data.Char (toLower)

7+import qualified Data.HashMap.Strict as HM

7import Data.List.NonEmpty (NonEmpty((:|)))

8import Data.List.NonEmpty (NonEmpty((:|)))

8import qualified Data.List.NonEmpty as NE

9import qualified Data.List.NonEmpty as NE

9import qualified Data.Scientific as SCI

10import qualified Data.Scientific as SCI

@@ -133,7 +134,7 @@ data JSONPointerError

133 deriving (Eq, Show)

134 deriving (Eq, Show)

134

135

135resolveFragment

136resolveFragment

136− :: forall schema. (FromJSON schema, ToJSON schema)

137+ :: (FromJSON schema, ToJSON schema)

137 => (BaseURI -> schema -> BaseURI)

138 => (BaseURI -> schema -> BaseURI)

138 -> Scope schema

139 -> Scope schema

139 -> Text

140 -> Text

@@ -158,17 +159,40 @@ resolveFragment updateScope scope fragment = do

158 -- as property keys that aren't meant to change scope?

159 -- as property keys that aren't meant to change scope?

159 -- Perhaps this should be added to the language agnostic

160 -- Perhaps this should be added to the language agnostic

160 -- test suite as well.

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

161 go :: (Value, BaseURI)

167 go :: (Value, BaseURI)

162 -> JP.Token

168 -> JP.Token

163 -> Either JSONPointerError (Value, BaseURI)

169 -> Either JSONPointerError (Value, BaseURI)

164− go (lastVal, uri) tok = do

170+ go (lastVal, baseURI) tok = do

165 v <- first ResolutionError (JP.resolveToken tok lastVal)

171 v <- first ResolutionError (JP.resolveToken tok lastVal)

166− case v of

172+ newBase <- newBaseURIFromFragment updateScope baseURI v

167− Array _ -> pure (v, uri)

173+ Right (v, newBase)

168− _ -> do

174+

169− -- PERFORMANCE: Avoid deserializing subschemas.

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

170− schema <- first SubschemaDecodingError (fromJSONEither v)

190+ schema <- first SubschemaDecodingError (fromJSONEither (Object hmWithOnlyId))

171− pure (v, updateScope uri schema)

191+ Right (updateScope baseURI schema)

192+ _ -> Right baseURI

193+ where

194+ idKey :: Text

195+ idKey = "id"

172

196

173--------------------------------------------------

197--------------------------------------------------

174-- * enum

198-- * enum