@@ -0,0 +1,509 @@
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