@@ -1,509 +0,0 @@
1−module JSONSchema.Validator.Draft4.Any where
2−
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(..),
19− URIAndFragment,
20− resolveReference)
21−import qualified JSONSchema.Validator.Utils as UT
22−
23−--------------------------------------------------
24−-- * $ref
25−--------------------------------------------------
26−
27−newtype Ref
28− = Ref { _unRef :: Text }
29− deriving (Eq, Show)
30−
31−instance FromJSON Ref where
32− parseJSON = withObject "Ref" $ \o ->
33− Ref <$> o .: "$ref"
34−
35−data RefInvalid err
36− = RefResolution Text
37− -- ^ Indicates a reference that failed to resolve.
38− --
39− -- NOTE: The language agnostic test suite doesn't specify if this should
40− -- cause a validation error or should allow data to pass. We choose to
41− -- return a validation error.
42− --
43− -- Also note that ideally we would enforce in the type system that any
44− -- failing references be dealt with before valididation. Then this could
45− -- be removed entirely.
46− | RefPointerResolution JSONPointerError
47− | RefLoop Text VisitedSchemas URIAndFragment
48− | RefInvalid Text Value (NonEmpty err)
49− -- ^ 'Text' is the URI and 'Value' is the linked schema.
50− deriving (Eq, Show)
51−
52−newtype VisitedSchemas
53− = VisitedSchemas { _unVisited :: [URIAndFragment] }
54− deriving (Eq, Show, Semigroup, Monoid)
55−
56−refVal
57− :: forall err schema. (FromJSON schema, ToJSON schema)
58− => (Text -> Maybe schema)
59− -- ^ Look up a schema.
60− -> (BaseURI -> schema -> BaseURI)
61− -- ^ Update scope (needed after moving deeper into nested schemas).
62− -> (VisitedSchemas -> Scope schema -> schema -> Value -> [err])
63− -- ^ Validate data.
64− -> VisitedSchemas
65− -> Scope schema
66− -> Ref
67− -> Value
68− -> Maybe (RefInvalid err)
69−refVal getRef updateScope val visited scope (Ref reference) x
70− | (mURI, mFragment) `elem` _unVisited visited =
71− Just (RefLoop reference visited (mURI, mFragment))
72− | otherwise = leftToMaybe $ do
73−
74− -- Get the referenced document
75−
76− (newScope, doc) <- first RefResolution
77− $ getDocument getRef updateScope scope mURI reference
78−
79− -- Get the correct subschema within that document.
80−
81− res <- case mFragment of
82− Nothing -> Right (newScope, doc)
83− Just fragment -> first RefPointerResolution
84− $ resolveFragment updateScope newScope fragment
85− let (finalScope, schema) = res
86−
87− -- Check if that schema is valid.
88−
89− let newVisited = VisitedSchemas [(_documentURI newScope, mFragment)]
90− <> visited
91− failures = val newVisited finalScope schema x
92− first (RefInvalid reference (toJSON schema))
93− . maybeToLeft ()
94− $ NE.nonEmpty failures
95− where
96− mURI :: Maybe Text
97− mFragment :: Maybe Text
98− (mURI, mFragment) = resolveReference (_currentBaseURI scope) reference
99−
100−getDocument
101− :: forall schema. (Text -> Maybe schema)
102− -> (BaseURI -> schema -> BaseURI)
103− -> Scope schema
104− -> Maybe Text
105− -> Text
106− -> Either Text (Scope schema, schema)
107− -- ^ 'Left' is the URI of the document we failed to resolve.
108−getDocument getRef updateScope scope mURI reference =
109− case mURI <* fst (resolveReference (BaseURI Nothing) reference) of
110− Nothing -> Right topOfThisDoc
111− Just uri ->
112− case getRef uri of
113− Nothing -> Left uri
114− Just s -> Right ( Scope s mURI (updateScope (BaseURI mURI) s)
115− , s
116− )
117− where
118− topOfThisDoc :: (Scope schema, schema)
119− topOfThisDoc =
120− ( scope { _currentBaseURI =
121− updateScope (BaseURI (_documentURI scope))
122− (_topLevelDocument scope)
123− }
124− , _topLevelDocument scope
125− )
126−
127−data JSONPointerError
128− = URLDecodingError UnicodeException
129− -- ^ Aspirationally internal.
130− | FormatError JP.FormatError
131− | ResolutionError JP.ResolutionError
132− | SubschemaDecodingError Text
133− -- ^ Aspirationally internal.
134− deriving (Eq, Show)
135−
136−resolveFragment
137− :: (FromJSON schema, ToJSON schema)
138− => (BaseURI -> schema -> BaseURI)
139− -> Scope schema
140− -> Text
141− -> Either JSONPointerError (Scope schema, schema)
142−resolveFragment updateScope scope fragment = do
143− urlDecoded <- first URLDecodingError
144− . decodeUtf8'
145− . urlDecode True
146− . encodeUtf8
147− $ fragment
148− JP.Pointer tokens <- first FormatError (JP.unescape urlDecoded)
149− let acc = (toJSON (_topLevelDocument scope), _currentBaseURI scope)
150− (schemaVal, base) <- foldM go acc tokens
151− schema <- first SubschemaDecodingError (fromJSONEither schemaVal)
152− pure (scope { _currentBaseURI = base }, schema)
153− where
154− -- We have to step through the document JSON Pointer token
155− -- by JSON Pointer token so that we can update the scope
156− -- based on each @"id"@ we encounter.
157− --
158− -- TODO: Do we need specialized code to skip @"id"@s such
159− -- as property keys that aren't meant to change scope?
160− -- Perhaps this should be added to the language agnostic
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.
167− go :: (Value, BaseURI)
168− -> JP.Token
169− -> Either JSONPointerError (Value, BaseURI)
170− go (lastVal, baseURI) tok = do
171− 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"
196−
197−--------------------------------------------------
198−-- * enum
199−--------------------------------------------------
200−
201−-- | From the spec:
202−-- <http://json-schema.org/latest/json-schema-validation.html#anchor76>
203−--
204−-- > The value of this keyword MUST be an array.
205−-- > This array MUST have at least one element.
206−-- > Elements in the array MUST be unique.
207−--
208−-- NOTE: We don't enforce the uniqueness constraint in the haskell code,
209−-- but we do in the 'FromJSON' instance.
210−newtype EnumValidator
211− = EnumValidator { _unEnumValidator :: NonEmpty Value }
212− -- Given a choice, we'd prefer to enforce uniqueness through the type
213− -- system over having at least one element. To use a 'Set' though we'd
214− -- have to use 'OrdValue' here (there's no 'Ord' instance for plain Values)
215− -- and we'd rather not make users mess with 'OrdValue'.
216− deriving (Eq, Show)
217−
218−instance FromJSON EnumValidator where
219− parseJSON = withObject "EnumValidator" $ \o ->
220− EnumValidator <$> o .: "enum"
221−
222−instance Arbitrary EnumValidator where
223− arbitrary = do
224− xs <- (fmap.fmap) UT._unArbitraryValue arbitrary
225− case NE.nonEmpty (toUnique xs) of
226− Nothing -> EnumValidator . pure . UT._unArbitraryValue <$> arbitrary
227− Just ne -> pure (EnumValidator ne)
228− where
229− toUnique :: [Value] -> [Value]
230− toUnique = fmap UT._unOrdValue
231− . Set.toList
232− . Set.fromList
233− . fmap UT.OrdValue
234−
235−data EnumInvalid
236− = EnumInvalid EnumValidator Value
237− deriving (Eq, Show)
238−
239−enumVal :: EnumValidator -> Value -> Maybe EnumInvalid
240−enumVal a@(EnumValidator vs) x
241− | not (UT.allUniqueValues vs) = Nothing
242− | x `elem` vs = Nothing
243− | otherwise = Just $ EnumInvalid a x
244−
245−--------------------------------------------------
246−-- * type
247−--------------------------------------------------
248−
249−-- | This is separate from 'TypeValidator' so that 'TypeValidator' can
250−-- be used to write 'JSONSchema.Draft4.Schema.Schema' without
251−-- messing up the 'FromJSON' instance of that data type.
252−newtype TypeContext
253− = TypeContext { _unTypeContext :: TypeValidator }
254− deriving (Eq, Show)
255−
256−instance FromJSON TypeContext where
257− parseJSON = withObject "TypeContext" $ \o ->
258− TypeContext <$> o .: "type"
259−
260−data TypeValidator
261− = TypeValidatorString SchemaType
262− | TypeValidatorArray (Set SchemaType)
263− deriving (Eq, Show)
264−
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−
280−instance FromJSON TypeValidator where
281− parseJSON v = fmap TypeValidatorString (parseJSON v)
282− <|> fmap TypeValidatorArray (parseJSON v)
283−
284−instance ToJSON TypeValidator where
285− toJSON (TypeValidatorString t) = toJSON t
286− toJSON (TypeValidatorArray ts) = toJSON ts
287−
288−instance Arbitrary TypeValidator where
289− arbitrary = oneof [ TypeValidatorString <$> arbitrary
290− , TypeValidatorArray <$> arbitrary
291− ]
292−
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−
316−data TypeValidatorInvalid
317− = TypeValidatorInvalid TypeValidator Value
318− deriving (Eq, Show)
319−
320−typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
321−typeVal (TypeContext tv) x
322− | Set.null matches = Just (TypeValidatorInvalid tv x)
323− | otherwise = Nothing
324− where
325− -- There can be more than one match because a 'Value' can be both a
326− -- @"number"@ and an @"integer"@.
327− matches :: Set SchemaType
328− matches = Set.intersection okTypes (setFromTypeValidator tv)
329−
330− okTypes :: Set SchemaType
331− okTypes =
332− case x of
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
338− (Number y) ->
339− if SCI.isInteger y
340− then Set.fromList [SchemaNumber, SchemaInteger]
341− else Set.singleton SchemaNumber
342−
343−-- | Internal.
344−setFromTypeValidator :: TypeValidator -> Set SchemaType
345−setFromTypeValidator (TypeValidatorString t) = Set.singleton t
346−setFromTypeValidator (TypeValidatorArray ts) = ts
347−
348−--------------------------------------------------
349−-- * allOf
350−--------------------------------------------------
351−
352−newtype AllOf schema
353− = AllOf { _unAllOf :: NonEmpty schema }
354− deriving (Eq, Show)
355−
356−instance FromJSON schema => FromJSON (AllOf schema) where
357− parseJSON = withObject "AllOf" $ \o ->
358− AllOf <$> o .: "allOf"
359−
360−newtype AllOfInvalid err
361− = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err))
362− deriving (Eq, Show)
363−
364−allOfVal
365− :: forall err schema.
366− (schema -> Value -> [err])
367− -> AllOf schema
368− -> Value
369− -> Maybe (AllOfInvalid err)
370−allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures
371− where
372− perhapsFailures :: [(JP.Index, [err])]
373− perhapsFailures = zip (JP.Index <$> [0..])
374− (flip f x <$> NE.toList subSchemas)
375−
376− failures :: [(JP.Index, NonEmpty err)]
377− failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures
378−
379−--------------------------------------------------
380−-- * anyOf
381−--------------------------------------------------
382−
383−newtype AnyOf schema
384− = AnyOf { _unAnyOf :: NonEmpty schema }
385− deriving (Eq, Show)
386−
387−instance FromJSON schema => FromJSON (AnyOf schema) where
388− parseJSON = withObject "AnyOf" $ \o ->
389− AnyOf <$> o .: "anyOf"
390−
391−newtype AnyOfInvalid err
392− = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err))
393− deriving (Eq, Show)
394−
395−anyOfVal
396− :: forall err schema.
397− (schema -> Value -> [err])
398− -> AnyOf schema
399− -> Value
400− -> Maybe (AnyOfInvalid err)
401−anyOfVal f (AnyOf subSchemas) x
402− | any (null . snd) perhapsFailures = Nothing
403− | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
404− where
405− perhapsFailures :: [(JP.Index, [err])]
406− perhapsFailures = zip (JP.Index <$> [0..])
407− (flip f x <$> NE.toList subSchemas)
408−
409− failures :: [(JP.Index, NonEmpty err)]
410− failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures
411−
412−--------------------------------------------------
413−-- * oneOf
414−--------------------------------------------------
415−
416−newtype OneOf schema
417− = OneOf { _unOneOf :: NonEmpty schema }
418− deriving (Eq, Show)
419−
420−instance FromJSON schema => FromJSON (OneOf schema) where
421− parseJSON = withObject "OneOf" $ \o ->
422− OneOf <$> o .: "oneOf"
423−
424−data OneOfInvalid err
425− = TooManySuccesses (NonEmpty (JP.Index, Value)) Value
426− -- ^ The NonEmpty lists contains tuples whose contents
427− -- are the index of a schema that validated the data
428− -- and the contents of that schema.
429− | NoSuccesses (NonEmpty (JP.Index, NonEmpty err)) Value
430− -- ^ The NonEmpty lists contains tuples whose contents
431− -- are the index of a schema that failed to validate the data
432− -- and the failures it produced.
433− deriving (Eq, Show)
434−
435−oneOfVal
436− :: forall err schema. ToJSON schema
437− => (schema -> Value -> [err])
438− -> OneOf schema
439− -> Value
440− -> Maybe (OneOfInvalid err)
441−oneOfVal f (OneOf (firstSubSchema :| otherSubSchemas)) x =
442− -- Producing the NonEmpty lists needed by the error constructors
443− -- is a little tricky. If we had a partition function like this
444− -- it might help:
445− -- @
446− -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c])
447− -- ([b], NonEmpty c)
448− -- @
449− case (firstSuccess, otherSuccesses) of
450− (Right _, Nothing) -> Nothing
451− (Right a, Just successes) -> Just (TooManySuccesses
452− (a NE.<| successes) x)
453− (Left e, Nothing) -> Just (NoSuccesses (e :| otherFailures) x)
454− (Left _, Just (_ :| [])) -> Nothing
455− (Left _, Just successes) -> Just (TooManySuccesses successes x)
456− where
457− firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value)
458− firstSuccess =
459− case NE.nonEmpty (f firstSubSchema x) of
460− Nothing -> Right (JP.Index 0, toJSON firstSubSchema)
461− Just errs -> Left (JP.Index 0, errs)
462−
463− otherPerhapsFailures :: [(JP.Index, Value, [err])]
464− otherPerhapsFailures =
465− zipWith
466− (\index schema -> (index, toJSON schema, f schema x))
467− (JP.Index <$> [0..])
468− otherSubSchemas
469−
470− otherSuccesses :: Maybe (NonEmpty (JP.Index, Value))
471− otherSuccesses = NE.nonEmpty
472− $ mapMaybe (\(index,val,errs) ->
473− case errs of
474− [] -> Just (index,val)
475− _ -> Nothing
476− ) otherPerhapsFailures
477−
478− otherFailures :: [(JP.Index, NonEmpty err)]
479− otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures
480−
481− mid :: (a,b,c) -> (a,c)
482− mid (a,_,c) = (a,c)
483−
484−--------------------------------------------------
485−-- * not
486−--------------------------------------------------
487−
488−newtype NotValidator schema
489− = NotValidator { _unNotValidator :: schema }
490− deriving (Eq, Show)
491−
492−instance FromJSON schema => FromJSON (NotValidator schema) where
493− parseJSON = withObject "NotValidator" $ \o ->
494− NotValidator <$> o .: "not"
495−
496−data NotValidatorInvalid
497− = NotValidatorInvalid Value Value
498− deriving (Eq, Show)
499−
500−notVal
501− :: ToJSON schema =>
502− (schema -> Value -> [err])
503− -> NotValidator schema
504− -> Value
505− -> Maybe NotValidatorInvalid
506−notVal f (NotValidator schema) x =
507− case f schema x of
508− [] -> Just (NotValidatorInvalid (toJSON schema) x)
509− _ -> Nothing