@@ -1,24 +1,25 @@
1+
12module JSONSchema.Validator.Draft4.Any where
23
3−import Import hiding ((<>))
4+import Import hiding ((<>))
45
5−import Data.Aeson.TH (constructorTagModifier)
6−import Data.Char (toLower)
7−import qualified Data.HashMap.Strict as HM
8−import Data.List.NonEmpty (NonEmpty((:|)))
9−import qualified Data.List.NonEmpty as NE
10−import qualified Data.Scientific as SCI
6+import Data.Aeson.TH (constructorTagModifier)
7+import Data.Char (toLower)
8+import Data.List.NonEmpty (NonEmpty((:|)))
9+import qualified Data.List.NonEmpty as NE
10+import qualified Data.Scientific as SCI
1111import Data.Semigroup
12−import Data.Set (Set)
13−import qualified Data.Set as Set
14−import Data.Text.Encoding.Error (UnicodeException)
15−import qualified JSONPointer as JP
16−import Network.HTTP.Types.URI (urlDecode)
17−
18−import JSONSchema.Validator.Reference (BaseURI(..), Scope(..),
12+import Data.Set (Set)
13+import qualified Data.Set as Set
14+import Data.Text.Encoding.Error (UnicodeException)
15+import qualified JSONPointer as JP
16+import Network.HTTP.Types.URI (urlDecode)
17+
18+import qualified JSONSchema.Validator.Utils as UT
19+import JSONSchema.Validator.Reference (BaseURI(..),
20+ Scope(..),
1921 URIAndFragment,
2022 resolveReference)
21−import qualified JSONSchema.Validator.Utils as UT
2223
2324--------------------------------------------------
2425-- * $ref
@@ -134,7 +135,7 @@ data JSONPointerError
134135 deriving (Eq, Show)
135136
136137resolveFragment
137− :: (FromJSON schema, ToJSON schema)
138+ :: forall schema. (FromJSON schema, ToJSON schema)
138139 => (BaseURI -> schema -> BaseURI)
139140 -> Scope schema
140141 -> Text
@@ -159,40 +160,17 @@ resolveFragment updateScope scope fragment = do
159160 -- as property keys that aren't meant to change scope?
160161 -- Perhaps this should be added to the language agnostic
161162 -- 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.
167163 go :: (Value, BaseURI)
168164 -> JP.Token
169165 -> Either JSONPointerError (Value, BaseURI)
170− go (lastVal, baseURI) tok = do
166+ go (lastVal, uri) tok = do
171167 v <- first ResolutionError (JP.resolveToken tok lastVal)
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"
168+ case v of
169+ Array _ -> pure (v, uri)
170+ _ -> do
171+ -- PERFORMANCE: Avoid deserializing subschemas.
172+ schema <- first SubschemaDecodingError (fromJSONEither v)
173+ pure (v, updateScope uri schema)
196174
197175--------------------------------------------------
198176-- * enum