master..2baee34 · typeable/hjsonschema

git.iko.soy/typeable/hjsonschema

on 2baee34 help sign in

.travis.yml+3

since splitsnapshots

unifiedsplit

@@ -26,6 +26,9 @@ 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]}}

29 - compiler: "ghc-8.0.2"

32 - compiler: "ghc-8.0.2"

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

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

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

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

changelog.md−6

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

1# 1.8.0

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−

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

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

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

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

hjsonschema.cabal+7−2

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

1name: hjsonschema

2−version: 1.9.0

2+version: 1.8.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 == 8.0.2, GHC == 8.2.2, GHC == 8.4.1

13+Tested-With: GHC == 7.10.3, 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,9 +77,12 @@ library

77 , QuickCheck >= 2.8

78 , safe-exceptions >= 0.1.6

79 , scientific >= 0.3

80+ , semigroups >= 0.18

80 , unordered-containers >= 0.2

81 , unordered-containers >= 0.2

81 , text >= 1.1

82 , text >= 1.1

82 , vector >= 0.10

83 , vector >= 0.10

84+ if impl(ghc < 8.0)

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

84test-suite local

87test-suite local

85 hs-source-dirs:

88 hs-source-dirs:

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

114 , hjsonschema

117 , hjsonschema

115 , profunctors

118 , profunctors

116 , protolude

119 , protolude

120+ , semigroups

117 , text

121 , text

118 , QuickCheck

122 , QuickCheck

119 , unordered-containers

123 , unordered-containers

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

152 , hjsonschema

156 , hjsonschema

153 , profunctors

157 , profunctors

154 , protolude

158 , protolude

159+ , semigroups

155 , text

160 , text

156 , unordered-containers

161 , unordered-containers

157 , vector

162 , vector

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

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

5import Data.Aeson.TH (constructorTagModifier)

6import Data.Char (toLower)

7−import qualified Data.HashMap.Strict as HM

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

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

9import qualified Data.List.NonEmpty as NE

8import qualified Data.List.NonEmpty as NE

10import qualified Data.Scientific as SCI

9import qualified Data.Scientific as SCI

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

134 deriving (Eq, Show)

133 deriving (Eq, Show)

135

134

136resolveFragment

135resolveFragment

137− :: (FromJSON schema, ToJSON schema)

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

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

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

139 -> Scope schema

138 -> Scope schema

140 -> Text

139 -> Text

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

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

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

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

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

161 -- test suite as well.

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

167 go :: (Value, BaseURI)

161 go :: (Value, BaseURI)

168 -> JP.Token

162 -> JP.Token

169 -> Either JSONPointerError (Value, BaseURI)

163 -> Either JSONPointerError (Value, BaseURI)

170− go (lastVal, baseURI) tok = do

164+ go (lastVal, uri) tok = do

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

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

172− newBase <- newBaseURIFromFragment updateScope baseURI v

166+ case v of

173− Right (v, newBase)

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

174−

168+ _ -> do

175−-- | Update the 'BaseURI' (the store of the current "id" value)

169+ -- PERFORMANCE: Avoid deserializing subschemas.

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

170+ schema <- first SubschemaDecodingError (fromJSONEither v)

191− Right (updateScope baseURI schema)

171+ pure (v, updateScope uri schema)

192− _ -> Right baseURI

193− where

194− idKey :: Text

195− idKey = "id"

196

172

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

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

198-- * enum

174-- * enum