@@ -1,24 +1,20 @@
1+
12module JSONSchema.Validator.Draft4.Any where
23
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,
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 qualified JSONPointer as JP
13+
14+import qualified JSONSchema.Validator.Utils as UT
15+import JSONSchema.Validator.Reference (URIBaseAndFragment,
16+ resolveFragment,
2017 resolveReference)
21−import qualified JSONSchema.Validator.Utils as UT
2218
2319--------------------------------------------------
2420-- * $ref
@@ -43,156 +39,42 @@ data RefInvalid err
4339 -- Also note that ideally we would enforce in the type system that any
4440 -- failing references be dealt with before valididation. Then this could
4541 -- be removed entirely.
46− | RefPointerResolution JSONPointerError
47− | RefLoop Text VisitedSchemas URIAndFragment
42+ | RefPointerResolution Text
43+ | RefLoop Text VisitedSchemas URIBaseAndFragment
4844 | RefInvalid Text Value (NonEmpty err)
4945 -- ^ 'Text' is the URI and 'Value' is the linked schema.
5046 deriving (Eq, Show)
5147
5248newtype VisitedSchemas
53− = VisitedSchemas { _unVisited :: [URIAndFragment] }
49+ = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }
5450 deriving (Eq, Show, Semigroup, Monoid)
5551
5652refVal
5753 :: 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
54+ => VisitedSchemas
55+ -> Maybe Text
56+ -> (Maybe Text -> Maybe schema)
57+ -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])
6658 -> Ref
6759 -> Value
6860 -> Maybe (RefInvalid err)
69−refVal getRef updateScope val visited scope (Ref reference) x
61+refVal visited scope getRef f (Ref reference) x
7062 | (mURI, mFragment) `elem` _unVisited visited =
7163 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
64+ | otherwise =
65+ case getRef mURI of
66+ Nothing -> Just (RefResolution reference)
67+ Just schema ->
68+ case resolveFragment mFragment schema of
69+ Nothing -> Just (RefPointerResolution reference)
70+ Just s ->
71+ let newVisited = (VisitedSchemas [(mURI, mFragment)]
72+ <> visited)
73+ errs = f newVisited mURI s x
74+ in RefInvalid reference (toJSON schema)
75+ <$> NE.nonEmpty errs
9576 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"
77+ (mURI, mFragment) = resolveReference scope reference
19678
19779--------------------------------------------------
19880-- * enum
@@ -227,10 +109,7 @@ instance Arbitrary EnumValidator where
227109 Just ne -> pure (EnumValidator ne)
228110 where
229111 toUnique :: [Value] -> [Value]
230− toUnique = fmap UT._unOrdValue
231− . Set.toList
232− . Set.fromList
233− . fmap UT.OrdValue
112+ toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue
234113
235114data EnumInvalid
236115 = EnumInvalid EnumValidator Value
@@ -238,9 +117,9 @@ data EnumInvalid
238117
239118enumVal :: EnumValidator -> Value -> Maybe EnumInvalid
240119enumVal a@(EnumValidator vs) x
241− | not (UT.allUniqueValues vs) = Nothing
242− | x `elem` vs = Nothing
243− | otherwise = Just $ EnumInvalid a x
120+ | not (UT.allUniqueValues' vs) = Nothing
121+ | x `elem` vs = Nothing
122+ | otherwise = Just $ EnumInvalid a x
244123
245124--------------------------------------------------
246125-- * type
@@ -258,25 +137,10 @@ instance FromJSON TypeContext where
258137 TypeContext <$> o .: "type"
259138
260139data TypeValidator
261− = TypeValidatorString SchemaType
262− | TypeValidatorArray (Set SchemaType)
140+ = TypeValidatorString Text
141+ | TypeValidatorArray (Set Text)
263142 deriving (Eq, Show)
264143
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−
280144instance FromJSON TypeValidator where
281145 parseJSON v = fmap TypeValidatorString (parseJSON v)
282146 <|> fmap TypeValidatorArray (parseJSON v)
@@ -286,63 +150,40 @@ instance ToJSON TypeValidator where
286150 toJSON (TypeValidatorArray ts) = toJSON ts
287151
288152instance Arbitrary TypeValidator where
289− arbitrary = oneof [ TypeValidatorString <$> arbitrary
290− , TypeValidatorArray <$> arbitrary
153+ arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText
154+ , TypeValidatorArray <$> UT.arbitrarySetOfText
291155 ]
292156
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−
316157data TypeValidatorInvalid
317158 = TypeValidatorInvalid TypeValidator Value
318159 deriving (Eq, Show)
319160
320161typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
321162typeVal (TypeContext tv) x
322− | Set.null matches = Just (TypeValidatorInvalid tv x)
323− | otherwise = Nothing
163+ | S.null matches = Just (TypeValidatorInvalid tv x)
164+ | otherwise = Nothing
324165 where
325166 -- There can be more than one match because a 'Value' can be both a
326167 -- @"number"@ and an @"integer"@.
327− matches :: Set SchemaType
328− matches = Set.intersection okTypes (setFromTypeValidator tv)
168+ matches :: Set Text
169+ matches = S.intersection okTypes (setFromTypeValidator tv)
329170
330− okTypes :: Set SchemaType
171+ okTypes :: Set Text
331172 okTypes =
332173 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
174+ Null -> S.singleton "null"
175+ (Array _) -> S.singleton "array"
176+ (Bool _) -> S.singleton "boolean"
177+ (Object _) -> S.singleton "object"
178+ (String _) -> S.singleton "string"
338179 (Number y) ->
339180 if SCI.isInteger y
340− then Set.fromList [SchemaNumber, SchemaInteger]
341− else Set.singleton SchemaNumber
181+ then S.fromList ["number", "integer"]
182+ else S.singleton "number"
342183
343184-- | Internal.
344−setFromTypeValidator :: TypeValidator -> Set SchemaType
345−setFromTypeValidator (TypeValidatorString t) = Set.singleton t
185+setFromTypeValidator :: TypeValidator -> Set Text
186+setFromTypeValidator (TypeValidatorString t) = S.singleton t
346187setFromTypeValidator (TypeValidatorArray ts) = ts
347188
348189--------------------------------------------------
@@ -399,7 +240,8 @@ anyOfVal
399240 -> Value
400241 -> Maybe (AnyOfInvalid err)
401242anyOfVal f (AnyOf subSchemas) x
402− | any (null . snd) perhapsFailures = Nothing
243+ -- Replace with @null@ once we drop GHC 7.8:
244+ | any (((==) 0 . length) . snd) perhapsFailures = Nothing
403245 | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
404246 where
405247 perhapsFailures :: [(JP.Index, [err])]