@@ -1,25 +1,24 @@
1−
21module JSONSchema.Validator.Draft4.Any where
32
4−import Import hiding ((<>))
3+import Import hiding ((<>))
54
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
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
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 qualified JSONSchema.Validator.Utils as UT
19−import JSONSchema.Validator.Reference (BaseURI(..),
20− 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 JSONSchema.Validator.Reference (BaseURI(..), Scope(..),
2119 URIAndFragment,
2220 resolveReference)
21+import qualified JSONSchema.Validator.Utils as UT
2322
2423--------------------------------------------------
2524-- * $ref
@@ -135,7 +134,7 @@ data JSONPointerError
135134 deriving (Eq, Show)
136135
137136resolveFragment
138− :: forall schema. (FromJSON schema, ToJSON schema)
137+ :: (FromJSON schema, ToJSON schema)
139138 => (BaseURI -> schema -> BaseURI)
140139 -> Scope schema
141140 -> Text
@@ -160,17 +159,40 @@ resolveFragment updateScope scope fragment = do
160159 -- as property keys that aren't meant to change scope?
161160 -- Perhaps this should be added to the language agnostic
162161 -- 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.
163167 go :: (Value, BaseURI)
164168 -> JP.Token
165169 -> Either JSONPointerError (Value, BaseURI)
166− go (lastVal, uri) tok = do
170+ go (lastVal, baseURI) tok = do
167171 v <- first ResolutionError (JP.resolveToken tok lastVal)
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)
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"
174196
175197--------------------------------------------------
176198-- * enum
@@ -216,9 +238,9 @@ data EnumInvalid
216238
217239enumVal :: EnumValidator -> Value -> Maybe EnumInvalid
218240enumVal a@(EnumValidator vs) x
219− | not (UT.allUniqueValues' vs) = Nothing
220− | x `elem` vs = Nothing
221− | otherwise = Just $ EnumInvalid a x
241+ | not (UT.allUniqueValues vs) = Nothing
242+ | x `elem` vs = Nothing
243+ | otherwise = Just $ EnumInvalid a x
222244
223245--------------------------------------------------
224246-- * type
@@ -377,8 +399,7 @@ anyOfVal
377399 -> Value
378400 -> Maybe (AnyOfInvalid err)
379401anyOfVal f (AnyOf subSchemas) x
380− -- Replace with @null@ once we drop GHC 7.8:
381− | any (((==) 0 . length) . snd) perhapsFailures = Nothing
402+ | any (null . snd) perhapsFailures = Nothing
382403 | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
383404 where
384405 perhapsFailures :: [(JP.Index, [err])]