@@ -1,509 +0,0 @@
1−module JSONSchema.Validator.Draft4.Any where
3−import Import hiding ((<>))
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
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)
18−import JSONSchema.Validator.Reference (BaseURI(..), Scope(..),
21−import qualified JSONSchema.Validator.Utils as UT
23−--------------------------------------------------
25−--------------------------------------------------
28− = Ref { _unRef :: Text }
31−instance FromJSON Ref where
32− parseJSON = withObject "Ref" $ \o ->
37− -- ^ Indicates a reference that failed to resolve.
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.
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.
52−newtype VisitedSchemas
53− = VisitedSchemas { _unVisited :: [URIAndFragment] }
54− deriving (Eq, Show, Semigroup, Monoid)
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])
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
74− -- Get the referenced document
76− (newScope, doc) <- first RefResolution
77− $ getDocument getRef updateScope scope mURI reference
79− -- Get the correct subschema within that document.
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
87− -- Check if that schema is valid.
89− let newVisited = VisitedSchemas [(_documentURI newScope, mFragment)]
91− failures = val newVisited finalScope schema x
92− first (RefInvalid reference (toJSON schema))
94− $ NE.nonEmpty failures
97− mFragment :: Maybe Text
98− (mURI, mFragment) = resolveReference (_currentBaseURI scope) reference
101− :: forall schema. (Text -> Maybe schema)
102− -> (BaseURI -> schema -> BaseURI)
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
114− Just s -> Right ( Scope s mURI (updateScope (BaseURI mURI) s)
118− topOfThisDoc :: (Scope schema, schema)
120− ( scope { _currentBaseURI =
121− updateScope (BaseURI (_documentURI scope))
122− (_topLevelDocument scope)
124− , _topLevelDocument scope
127−data JSONPointerError
128− = URLDecodingError UnicodeException
129− -- ^ Aspirationally internal.
130− | FormatError JP.FormatError
131− | ResolutionError JP.ResolutionError
132− | SubschemaDecodingError Text
133− -- ^ Aspirationally internal.
137− :: (FromJSON schema, ToJSON schema)
138− => (BaseURI -> schema -> BaseURI)
141− -> Either JSONPointerError (Scope schema, schema)
142−resolveFragment updateScope scope fragment = do
143− urlDecoded <- first URLDecodingError
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)
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.
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.
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)
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
175−-- | Update the 'BaseURI' (the store of the current "id" value)
176−-- after resolving one token of a JSON Pointer and stepping into
178−newBaseURIFromFragment
180− => (BaseURI -> schema -> BaseURI)
183− -> Either JSONPointerError BaseURI
184−newBaseURIFromFragment updateScope baseURI v =
187− let hmWithOnlyId = case HM.lookup idKey hm of
189− Just idVal -> HM.singleton idKey idVal
190− schema <- first SubschemaDecodingError (fromJSONEither (Object hmWithOnlyId))
191− Right (updateScope baseURI schema)
197−--------------------------------------------------
199−--------------------------------------------------
202−-- <http://json-schema.org/latest/json-schema-validation.html#anchor76>
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.
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'.
218−instance FromJSON EnumValidator where
219− parseJSON = withObject "EnumValidator" $ \o ->
220− EnumValidator <$> o .: "enum"
222−instance Arbitrary EnumValidator where
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)
229− toUnique :: [Value] -> [Value]
230− toUnique = fmap UT._unOrdValue
236− = EnumInvalid EnumValidator Value
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
245−--------------------------------------------------
247−--------------------------------------------------
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.
253− = TypeContext { _unTypeContext :: TypeValidator }
256−instance FromJSON TypeContext where
257− parseJSON = withObject "TypeContext" $ \o ->
258− TypeContext <$> o .: "type"
261− = TypeValidatorString SchemaType
262− | TypeValidatorArray (Set SchemaType)
265−instance Semigroup TypeValidator where
270− | otherwise = TypeValidatorArray (setFromTypeValidator x
272− setFromTypeValidator y)
274− isEmpty :: TypeValidator -> Bool
275− isEmpty (TypeValidatorString _) = False
276− isEmpty (TypeValidatorArray ts) = Set.null ts
278− stimes = stimesIdempotent
280−instance FromJSON TypeValidator where
281− parseJSON v = fmap TypeValidatorString (parseJSON v)
282− <|> fmap TypeValidatorArray (parseJSON v)
284−instance ToJSON TypeValidator where
285− toJSON (TypeValidatorString t) = toJSON t
286− toJSON (TypeValidatorArray ts) = toJSON ts
288−instance Arbitrary TypeValidator where
289− arbitrary = oneof [ TypeValidatorString <$> arbitrary
290− , TypeValidatorArray <$> arbitrary
301− deriving (Eq, Ord, Show, Bounded, Enum, Generic)
303−instance FromJSON SchemaType where
304− parseJSON = genericParseJSON
306− { constructorTagModifier = fmap toLower . drop 6 }
308−instance ToJSON SchemaType where
309− toJSON = genericToJSON
311− { constructorTagModifier = fmap toLower . drop 6 }
313−instance Arbitrary SchemaType where
314− arbitrary = arbitraryBoundedEnum
316−data TypeValidatorInvalid
317− = TypeValidatorInvalid TypeValidator Value
320−typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
321−typeVal (TypeContext tv) x
322− | Set.null matches = Just (TypeValidatorInvalid tv x)
323− | otherwise = Nothing
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)
330− okTypes :: Set SchemaType
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
340− then Set.fromList [SchemaNumber, SchemaInteger]
341− else Set.singleton SchemaNumber
344−setFromTypeValidator :: TypeValidator -> Set SchemaType
345−setFromTypeValidator (TypeValidatorString t) = Set.singleton t
346−setFromTypeValidator (TypeValidatorArray ts) = ts
348−--------------------------------------------------
350−--------------------------------------------------
353− = AllOf { _unAllOf :: NonEmpty schema }
356−instance FromJSON schema => FromJSON (AllOf schema) where
357− parseJSON = withObject "AllOf" $ \o ->
358− AllOf <$> o .: "allOf"
360−newtype AllOfInvalid err
361− = AllOfInvalid (NonEmpty (JP.Index, NonEmpty err))
365− :: forall err schema.
366− (schema -> Value -> [err])
369− -> Maybe (AllOfInvalid err)
370−allOfVal f (AllOf subSchemas) x = AllOfInvalid <$> NE.nonEmpty failures
372− perhapsFailures :: [(JP.Index, [err])]
373− perhapsFailures = zip (JP.Index <$> [0..])
374− (flip f x <$> NE.toList subSchemas)
376− failures :: [(JP.Index, NonEmpty err)]
377− failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures
379−--------------------------------------------------
381−--------------------------------------------------
384− = AnyOf { _unAnyOf :: NonEmpty schema }
387−instance FromJSON schema => FromJSON (AnyOf schema) where
388− parseJSON = withObject "AnyOf" $ \o ->
389− AnyOf <$> o .: "anyOf"
391−newtype AnyOfInvalid err
392− = AnyOfInvalid (NonEmpty (JP.Index, NonEmpty err))
396− :: forall err schema.
397− (schema -> Value -> [err])
400− -> Maybe (AnyOfInvalid err)
401−anyOfVal f (AnyOf subSchemas) x
402− | any (null . snd) perhapsFailures = Nothing
403− | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
405− perhapsFailures :: [(JP.Index, [err])]
406− perhapsFailures = zip (JP.Index <$> [0..])
407− (flip f x <$> NE.toList subSchemas)
409− failures :: [(JP.Index, NonEmpty err)]
410− failures = mapMaybe (traverse NE.nonEmpty) perhapsFailures
412−--------------------------------------------------
414−--------------------------------------------------
417− = OneOf { _unOneOf :: NonEmpty schema }
420−instance FromJSON schema => FromJSON (OneOf schema) where
421− parseJSON = withObject "OneOf" $ \o ->
422− OneOf <$> o .: "oneOf"
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.
436− :: forall err schema. ToJSON schema
437− => (schema -> Value -> [err])
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
446− -- (a -> Either b c) -> NonEmpty a -> Either (NonEmpty b, [c])
447− -- ([b], NonEmpty c)
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)
457− firstSuccess :: Either (JP.Index, NonEmpty err) (JP.Index, Value)
459− case NE.nonEmpty (f firstSubSchema x) of
460− Nothing -> Right (JP.Index 0, toJSON firstSubSchema)
461− Just errs -> Left (JP.Index 0, errs)
463− otherPerhapsFailures :: [(JP.Index, Value, [err])]
464− otherPerhapsFailures =
466− (\index schema -> (index, toJSON schema, f schema x))
467− (JP.Index <$> [0..])
470− otherSuccesses :: Maybe (NonEmpty (JP.Index, Value))
471− otherSuccesses = NE.nonEmpty
472− $ mapMaybe (\(index,val,errs) ->
474− [] -> Just (index,val)
476− ) otherPerhapsFailures
478− otherFailures :: [(JP.Index, NonEmpty err)]
479− otherFailures = mapMaybe (traverse NE.nonEmpty . mid) otherPerhapsFailures
481− mid :: (a,b,c) -> (a,c)
484−--------------------------------------------------
486−--------------------------------------------------
488−newtype NotValidator schema
489− = NotValidator { _unNotValidator :: schema }
492−instance FromJSON schema => FromJSON (NotValidator schema) where
493− parseJSON = withObject "NotValidator" $ \o ->
494− NotValidator <$> o .: "not"
496−data NotValidatorInvalid
497− = NotValidatorInvalid Value Value
502− (schema -> Value -> [err])
503− -> NotValidator schema
505− -> Maybe NotValidatorInvalid
506−notVal f (NotValidator schema) x =
508− [] -> Just (NotValidatorInvalid (toJSON schema) x)