@@ -1,23 +1,24 @@
1−
21module JSONSchema.Validator.Draft4.Any where
32
4−import Import
5−
6−import Data.List.NonEmpty (NonEmpty((:|)))
7−import qualified Data.List.NonEmpty as NE
8−import qualified Data.Scientific as SCI
9−import Data.Semigroup (Semigroup) -- for older GHCs
10−import Data.Set (Set)
11−import qualified Data.Set as S
12−import Data.Text.Encoding.Error (UnicodeException)
13−import qualified JSONPointer as JP
14−import Network.HTTP.Types.URI (urlDecode)
15−
16−import qualified JSONSchema.Validator.Utils as UT
17−import JSONSchema.Validator.Reference (BaseURI(..),
18− Scope(..),
3+import Import hiding ((<>))
4+
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
11+import 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(..),
1919 URIAndFragment,
2020 resolveReference)
21+import qualified JSONSchema.Validator.Utils as UT
2122
2223--------------------------------------------------
2324-- * $ref
@@ -124,14 +125,16 @@ getDocument getRef updateScope scope mURI reference =
124125 )
125126
126127data JSONPointerError
127− = URLDecodingError UnicodeException -- | Aspirationally internal.
128+ = URLDecodingError UnicodeException
129+ -- ^ Aspirationally internal.
128130 | FormatError JP.FormatError
129131 | ResolutionError JP.ResolutionError
130− | SubschemaDecodingError Text -- | Aspirationally internal.
132+ | SubschemaDecodingError Text
133+ -- ^ Aspirationally internal.
131134 deriving (Eq, Show)
132135
133136resolveFragment
134− :: forall schema. (FromJSON schema, ToJSON schema)
137+ :: (FromJSON schema, ToJSON schema)
135138 => (BaseURI -> schema -> BaseURI)
136139 -> Scope schema
137140 -> Text
@@ -156,17 +159,40 @@ resolveFragment updateScope scope fragment = do
156159 -- as property keys that aren't meant to change scope?
157160 -- Perhaps this should be added to the language agnostic
158161 -- 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.
159167 go :: (Value, BaseURI)
160168 -> JP.Token
161169 -> Either JSONPointerError (Value, BaseURI)
162− go (lastVal, uri) tok = do
170+ go (lastVal, baseURI) tok = do
163171 v <- first ResolutionError (JP.resolveToken tok lastVal)
164− case v of
165− Array _ -> pure (v, uri)
166− _ -> do
167− -- PERFORMANCE: Avoid deserializing subschemas.
168− schema <- first SubschemaDecodingError (fromJSONEither v)
169− 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"
170196
171197--------------------------------------------------
172198-- * enum
@@ -201,7 +227,10 @@ instance Arbitrary EnumValidator where
201227 Just ne -> pure (EnumValidator ne)
202228 where
203229 toUnique :: [Value] -> [Value]
204− toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue
230+ toUnique = fmap UT._unOrdValue
231+ . Set.toList
232+ . Set.fromList
233+ . fmap UT.OrdValue
205234
206235data EnumInvalid
207236 = EnumInvalid EnumValidator Value
@@ -209,9 +238,9 @@ data EnumInvalid
209238
210239enumVal :: EnumValidator -> Value -> Maybe EnumInvalid
211240enumVal a@(EnumValidator vs) x
212− | not (UT.allUniqueValues' vs) = Nothing
213− | x `elem` vs = Nothing
214− | otherwise = Just $ EnumInvalid a x
241+ | not (UT.allUniqueValues vs) = Nothing
242+ | x `elem` vs = Nothing
243+ | otherwise = Just $ EnumInvalid a x
215244
216245--------------------------------------------------
217246-- * type
@@ -229,10 +258,25 @@ instance FromJSON TypeContext where
229258 TypeContext <$> o .: "type"
230259
231260data TypeValidator
232− = TypeValidatorString Text
233− | TypeValidatorArray (Set Text)
261+ = TypeValidatorString SchemaType
262+ | TypeValidatorArray (Set SchemaType)
234263 deriving (Eq, Show)
235264
265+instance Semigroup TypeValidator where
266+ (<>) x y
267+ | isEmpty x = x
268+ | isEmpty y = y
269+ | x == y = x
270+ | otherwise = TypeValidatorArray (setFromTypeValidator x
271+ `Set.union`
272+ setFromTypeValidator y)
273+ where
274+ isEmpty :: TypeValidator -> Bool
275+ isEmpty (TypeValidatorString _) = False
276+ isEmpty (TypeValidatorArray ts) = Set.null ts
277+
278+ stimes = stimesIdempotent
279+
236280instance FromJSON TypeValidator where
237281 parseJSON v = fmap TypeValidatorString (parseJSON v)
238282 <|> fmap TypeValidatorArray (parseJSON v)
@@ -242,40 +286,63 @@ instance ToJSON TypeValidator where
242286 toJSON (TypeValidatorArray ts) = toJSON ts
243287
244288instance Arbitrary TypeValidator where
245− arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText
246− , TypeValidatorArray <$> UT.arbitrarySetOfText
289+ arbitrary = oneof [ TypeValidatorString <$> arbitrary
290+ , TypeValidatorArray <$> arbitrary
247291 ]
248292
293+data SchemaType
294+ = SchemaObject
295+ | SchemaArray
296+ | SchemaString
297+ | SchemaNumber
298+ | SchemaInteger
299+ | SchemaBoolean
300+ | SchemaNull
301+ deriving (Eq, Ord, Show, Bounded, Enum, Generic)
302+
303+instance FromJSON SchemaType where
304+ parseJSON = genericParseJSON
305+ defaultOptions
306+ { constructorTagModifier = fmap toLower . drop 6 }
307+
308+instance ToJSON SchemaType where
309+ toJSON = genericToJSON
310+ defaultOptions
311+ { constructorTagModifier = fmap toLower . drop 6 }
312+
313+instance Arbitrary SchemaType where
314+ arbitrary = arbitraryBoundedEnum
315+
249316data TypeValidatorInvalid
250317 = TypeValidatorInvalid TypeValidator Value
251318 deriving (Eq, Show)
252319
253320typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
254321typeVal (TypeContext tv) x
255− | S.null matches = Just (TypeValidatorInvalid tv x)
256− | otherwise = Nothing
322+ | Set.null matches = Just (TypeValidatorInvalid tv x)
323+ | otherwise = Nothing
257324 where
258325 -- There can be more than one match because a 'Value' can be both a
259326 -- @"number"@ and an @"integer"@.
260− matches :: Set Text
261− matches = S.intersection okTypes (setFromTypeValidator tv)
327+ matches :: Set SchemaType
328+ matches = Set.intersection okTypes (setFromTypeValidator tv)
262329
263− okTypes :: Set Text
330+ okTypes :: Set SchemaType
264331 okTypes =
265332 case x of
266− Null -> S.singleton "null"
267− (Array _) -> S.singleton "array"
268− (Bool _) -> S.singleton "boolean"
269− (Object _) -> S.singleton "object"
270− (String _) -> S.singleton "string"
333+ Null -> Set.singleton SchemaNull
334+ (Array _) -> Set.singleton SchemaArray
335+ (Bool _) -> Set.singleton SchemaBoolean
336+ (Object _) -> Set.singleton SchemaObject
337+ (String _) -> Set.singleton SchemaString
271338 (Number y) ->
272339 if SCI.isInteger y
273− then S.fromList ["number", "integer"]
274− else S.singleton "number"
340+ then Set.fromList [SchemaNumber, SchemaInteger]
341+ else Set.singleton SchemaNumber
275342
276343-- | Internal.
277−setFromTypeValidator :: TypeValidator -> Set Text
278−setFromTypeValidator (TypeValidatorString t) = S.singleton t
344+setFromTypeValidator :: TypeValidator -> Set SchemaType
345+setFromTypeValidator (TypeValidatorString t) = Set.singleton t
279346setFromTypeValidator (TypeValidatorArray ts) = ts
280347
281348--------------------------------------------------
@@ -332,8 +399,7 @@ anyOfVal
332399 -> Value
333400 -> Maybe (AnyOfInvalid err)
334401anyOfVal f (AnyOf subSchemas) x
335− -- Replace with @null@ once we drop GHC 7.8:
336− | any (((==) 0 . length) . snd) perhapsFailures = Nothing
402+ | any (null . snd) perhapsFailures = Nothing
337403 | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
338404 where
339405 perhapsFailures :: [(JP.Index, [err])]