@@ -1,24 +1,20 @@
1module JSONSchema.Validator.Draft4.Any where
2module JSONSchema.Validator.Draft4.Any where
3−import Import hiding ((<>))
4+import Import
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((:|)))
6+import Data.List.NonEmpty (NonEmpty((:|)))
9−import qualified Data.List.NonEmpty as NE
7+import qualified Data.List.NonEmpty as NE
10−import qualified Data.Scientific as SCI
8+import qualified Data.Scientific as SCI
11−import Data.Semigroup
9+import Data.Semigroup (Semigroup) -- for older GHCs
12−import Data.Set (Set)
10+import Data.Set (Set)
13−import qualified Data.Set as Set
11+import qualified Data.Set as S
14−import Data.Text.Encoding.Error (UnicodeException)
15−import qualified JSONPointer as JP
12+import qualified JSONPointer as JP
16−import Network.HTTP.Types.URI (urlDecode)
13+
17−
14+import qualified JSONSchema.Validator.Utils as UT
18−import JSONSchema.Validator.Reference (BaseURI(..), Scope(..),
15+import JSONSchema.Validator.Reference (URIBaseAndFragment,
19− URIAndFragment,
16+ resolveFragment,
20 resolveReference)
17 resolveReference)
21−import qualified JSONSchema.Validator.Utils as UT
23--------------------------------------------------
19--------------------------------------------------
@@ -43,156 +39,42 @@ data RefInvalid err
43 -- Also note that ideally we would enforce in the type system that any
39 -- Also note that ideally we would enforce in the type system that any
44 -- failing references be dealt with before valididation. Then this could
40 -- failing references be dealt with before valididation. Then this could
45 -- be removed entirely.
41 -- be removed entirely.
46− | RefPointerResolution JSONPointerError
42+ | RefPointerResolution Text
47− | RefLoop Text VisitedSchemas URIAndFragment
43+ | RefLoop Text VisitedSchemas URIBaseAndFragment
48 | RefInvalid Text Value (NonEmpty err)
44 | RefInvalid Text Value (NonEmpty err)
49 -- ^ 'Text' is the URI and 'Value' is the linked schema.
45 -- ^ 'Text' is the URI and 'Value' is the linked schema.
50 deriving (Eq, Show)
46 deriving (Eq, Show)
52newtype VisitedSchemas
48newtype VisitedSchemas
53− = VisitedSchemas { _unVisited :: [URIAndFragment] }
49+ = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }
54 deriving (Eq, Show, Semigroup, Monoid)
50 deriving (Eq, Show, Semigroup, Monoid)
57 :: forall err schema. (FromJSON schema, ToJSON schema)
53 :: forall err schema. (FromJSON schema, ToJSON schema)
58− => (Text -> Maybe schema)
55+ -> Maybe Text
59− -- ^ Look up a schema.
56+ -> (Maybe Text -> Maybe schema)
60− -> (BaseURI -> schema -> BaseURI)
61− -- ^ Update scope (needed after moving deeper into nested schemas).
62− -> (VisitedSchemas -> Scope schema -> schema -> Value -> [err])
57+ -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])
68 -> Maybe (RefInvalid err)
60 -> Maybe (RefInvalid err)
69−refVal getRef updateScope val visited scope (Ref reference) x
61+refVal visited scope getRef f (Ref reference) x
70 | (mURI, mFragment) `elem` _unVisited visited =
62 | (mURI, mFragment) `elem` _unVisited visited =
71 Just (RefLoop reference visited (mURI, mFragment))
63 Just (RefLoop reference visited (mURI, mFragment))
72− | otherwise = leftToMaybe $ do
64+ | otherwise =
73−
65+ case getRef mURI of
74− -- Get the referenced document
66+ Nothing -> Just (RefResolution reference)
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
68+ case resolveFragment mFragment schema of
82− Nothing -> Right (newScope, doc)
83− Just fragment -> first RefPointerResolution
69+ Nothing -> Just (RefPointerResolution reference)
84− $ resolveFragment updateScope newScope fragment
70+ Just s ->
85− let (finalScope, schema) = res
87− -- Check if that schema is valid.
89− let newVisited = VisitedSchemas [(_documentURI newScope, mFragment)]
71+ let newVisited = (VisitedSchemas [(mURI, mFragment)]
90− <> visited
72+ <> visited)
91− failures = val newVisited finalScope schema x
73+ errs = f newVisited mURI s x
92− first (RefInvalid reference (toJSON schema))
74+ in RefInvalid reference (toJSON schema)
94− $ NE.nonEmpty failures
75+ <$> NE.nonEmpty errs
97− mFragment :: Maybe Text
98− (mURI, mFragment) = resolveReference (_currentBaseURI scope) reference
77+ (mURI, mFragment) = resolveReference 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--------------------------------------------------
79--------------------------------------------------
@@ -227,10 +109,7 @@ instance Arbitrary EnumValidator where
227 Just ne -> pure (EnumValidator ne)
109 Just ne -> pure (EnumValidator ne)
229 toUnique :: [Value] -> [Value]
111 toUnique :: [Value] -> [Value]
230− toUnique = fmap UT._unOrdValue
112+ toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue
235data EnumInvalid
114data EnumInvalid
236 = EnumInvalid EnumValidator Value
115 = EnumInvalid EnumValidator Value
@@ -238,9 +117,9 @@ data EnumInvalid
239enumVal :: EnumValidator -> Value -> Maybe EnumInvalid
118enumVal :: EnumValidator -> Value -> Maybe EnumInvalid
240enumVal a@(EnumValidator vs) x
119enumVal a@(EnumValidator vs) x
241− | not (UT.allUniqueValues vs) = Nothing
120+ | not (UT.allUniqueValues' vs) = Nothing
242− | x `elem` vs = Nothing
121+ | x `elem` vs = Nothing
243− | otherwise = Just $ EnumInvalid a x
122+ | otherwise = Just $ EnumInvalid a x
245--------------------------------------------------
124--------------------------------------------------
@@ -258,25 +137,10 @@ instance FromJSON TypeContext where
258 TypeContext <$> o .: "type"
137 TypeContext <$> o .: "type"
260data TypeValidator
139data TypeValidator
261− = TypeValidatorString SchemaType
140+ = TypeValidatorString Text
262− | TypeValidatorArray (Set SchemaType)
141+ | TypeValidatorArray (Set Text)
263 deriving (Eq, Show)
142 deriving (Eq, Show)
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
280instance FromJSON TypeValidator where
144instance FromJSON TypeValidator where
281 parseJSON v = fmap TypeValidatorString (parseJSON v)
145 parseJSON v = fmap TypeValidatorString (parseJSON v)
282 <|> fmap TypeValidatorArray (parseJSON v)
146 <|> fmap TypeValidatorArray (parseJSON v)
@@ -286,63 +150,40 @@ instance ToJSON TypeValidator where
286 toJSON (TypeValidatorArray ts) = toJSON ts
150 toJSON (TypeValidatorArray ts) = toJSON ts
288instance Arbitrary TypeValidator where
152instance Arbitrary TypeValidator where
289− arbitrary = oneof [ TypeValidatorString <$> arbitrary
153+ arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText
290− , TypeValidatorArray <$> arbitrary
154+ , TypeValidatorArray <$> UT.arbitrarySetOfText
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
316data TypeValidatorInvalid
157data TypeValidatorInvalid
317 = TypeValidatorInvalid TypeValidator Value
158 = TypeValidatorInvalid TypeValidator Value
318 deriving (Eq, Show)
159 deriving (Eq, Show)
320typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
161typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
321typeVal (TypeContext tv) x
162typeVal (TypeContext tv) x
322− | Set.null matches = Just (TypeValidatorInvalid tv x)
163+ | S.null matches = Just (TypeValidatorInvalid tv x)
323− | otherwise = Nothing
164+ | otherwise = Nothing
325 -- There can be more than one match because a 'Value' can be both a
166 -- There can be more than one match because a 'Value' can be both a
326 -- @"number"@ and an @"integer"@.
167 -- @"number"@ and an @"integer"@.
327− matches :: Set SchemaType
168+ matches :: Set Text
328− matches = Set.intersection okTypes (setFromTypeValidator tv)
169+ matches = S.intersection okTypes (setFromTypeValidator tv)
330− okTypes :: Set SchemaType
171+ okTypes :: Set Text
331 okTypes =
172 okTypes =
332 case x of
173 case x of
333− Null -> Set.singleton SchemaNull
174+ Null -> S.singleton "null"
334− (Array _) -> Set.singleton SchemaArray
175+ (Array _) -> S.singleton "array"
335− (Bool _) -> Set.singleton SchemaBoolean
176+ (Bool _) -> S.singleton "boolean"
336− (Object _) -> Set.singleton SchemaObject
177+ (Object _) -> S.singleton "object"
337− (String _) -> Set.singleton SchemaString
178+ (String _) -> S.singleton "string"
338 (Number y) ->
179 (Number y) ->
339 if SCI.isInteger y
180 if SCI.isInteger y
340− then Set.fromList [SchemaNumber, SchemaInteger]
181+ then S.fromList ["number", "integer"]
341− else Set.singleton SchemaNumber
182+ else S.singleton "number"
343-- | Internal.
184-- | Internal.
344−setFromTypeValidator :: TypeValidator -> Set SchemaType
185+setFromTypeValidator :: TypeValidator -> Set Text
345−setFromTypeValidator (TypeValidatorString t) = Set.singleton t
186+setFromTypeValidator (TypeValidatorString t) = S.singleton t
346setFromTypeValidator (TypeValidatorArray ts) = ts
187setFromTypeValidator (TypeValidatorArray ts) = ts
348--------------------------------------------------
189--------------------------------------------------
@@ -399,7 +240,8 @@ anyOfVal
400 -> Maybe (AnyOfInvalid err)
241 -> Maybe (AnyOfInvalid err)
401anyOfVal f (AnyOf subSchemas) x
242anyOfVal f (AnyOf subSchemas) x
243+ -- Replace with @null@ once we drop GHC 7.8:
402− | any (null . snd) perhapsFailures = Nothing
244+ | any (((==) 0 . length) . snd) perhapsFailures = Nothing
403 | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
245 | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
405 perhapsFailures :: [(JP.Index, [err])]
247 perhapsFailures :: [(JP.Index, [err])]