@@ -1,19 +1,24 @@
1−
2−module Data.Validator.Draft4.Any where
3−
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 Data.Validator.Utils as UT
15−import Data.Validator.Reference (URIBaseAndFragment,
16− resolveFragment, resolveReference)
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
1722
1823--------------------------------------------------
1924-- * $ref
@@ -38,42 +43,156 @@ data RefInvalid err
3843 -- Also note that ideally we would enforce in the type system that any
3944 -- failing references be dealt with before valididation. Then this could
4045 -- be removed entirely.
41− | RefPointerResolution Text
42− | RefLoop Text VisitedSchemas URIBaseAndFragment
46+ | RefPointerResolution JSONPointerError
47+ | RefLoop Text VisitedSchemas URIAndFragment
4348 | RefInvalid Text Value (NonEmpty err)
4449 -- ^ 'Text' is the URI and 'Value' is the linked schema.
4550 deriving (Eq, Show)
4651
4752newtype VisitedSchemas
48− = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }
53+ = VisitedSchemas { _unVisited :: [URIAndFragment] }
4954 deriving (Eq, Show, Semigroup, Monoid)
5055
5156refVal
5257 :: forall err schema. (FromJSON schema, ToJSON schema)
53− => VisitedSchemas
54− -> Maybe Text
55− -> (Maybe Text -> Maybe schema)
56− -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])
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
5766 -> Ref
5867 -> Value
5968 -> Maybe (RefInvalid err)
60−refVal visited scope getRef f (Ref reference) x
69+refVal getRef updateScope val visited scope (Ref reference) x
6170 | (mURI, mFragment) `elem` _unVisited visited =
6271 Just (RefLoop reference visited (mURI, mFragment))
63− | otherwise =
64− case getRef mURI of
65− Nothing -> Just (RefResolution reference)
66− Just schema ->
67− case resolveFragment mFragment schema of
68− Nothing -> Just (RefPointerResolution reference)
69− Just s ->
70− let newVisited = (VisitedSchemas [(mURI, mFragment)]
71− <> visited)
72− errs = f newVisited mURI s x
73− in RefInvalid reference (toJSON schema)
74− <$> NE.nonEmpty errs
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
7595 where
76− (mURI, mFragment) = resolveReference scope reference
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"
77196
78197--------------------------------------------------
79198-- * enum
@@ -108,7 +227,10 @@ instance Arbitrary EnumValidator where
108227 Just ne -> pure (EnumValidator ne)
109228 where
110229 toUnique :: [Value] -> [Value]
111− toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue
230+ toUnique = fmap UT._unOrdValue
231+ . Set.toList
232+ . Set.fromList
233+ . fmap UT.OrdValue
112234
113235data EnumInvalid
114236 = EnumInvalid EnumValidator Value
@@ -116,16 +238,16 @@ data EnumInvalid
116238
117239enumVal :: EnumValidator -> Value -> Maybe EnumInvalid
118240enumVal a@(EnumValidator vs) x
119− | not (UT.allUniqueValues' vs) = Nothing
120− | x `elem` vs = Nothing
121− | otherwise = Just $ EnumInvalid a x
241+ | not (UT.allUniqueValues vs) = Nothing
242+ | x `elem` vs = Nothing
243+ | otherwise = Just $ EnumInvalid a x
122244
123245--------------------------------------------------
124246-- * type
125247--------------------------------------------------
126248
127249-- | This is separate from 'TypeValidator' so that 'TypeValidator' can
128−-- be used to write 'Data.JsonSchema.Draft4.Schema.Schema' without
250+-- be used to write 'JSONSchema.Draft4.Schema.Schema' without
129251-- messing up the 'FromJSON' instance of that data type.
130252newtype TypeContext
131253 = TypeContext { _unTypeContext :: TypeValidator }
@@ -136,10 +258,25 @@ instance FromJSON TypeContext where
136258 TypeContext <$> o .: "type"
137259
138260data TypeValidator
139− = TypeValidatorString Text
140− | TypeValidatorArray (Set Text)
261+ = TypeValidatorString SchemaType
262+ | TypeValidatorArray (Set SchemaType)
141263 deriving (Eq, Show)
142264
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+
143280instance FromJSON TypeValidator where
144281 parseJSON v = fmap TypeValidatorString (parseJSON v)
145282 <|> fmap TypeValidatorArray (parseJSON v)
@@ -149,40 +286,63 @@ instance ToJSON TypeValidator where
149286 toJSON (TypeValidatorArray ts) = toJSON ts
150287
151288instance Arbitrary TypeValidator where
152− arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText
153− , TypeValidatorArray <$> UT.arbitrarySetOfText
289+ arbitrary = oneof [ TypeValidatorString <$> arbitrary
290+ , TypeValidatorArray <$> arbitrary
154291 ]
155292
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+
156316data TypeValidatorInvalid
157317 = TypeValidatorInvalid TypeValidator Value
158318 deriving (Eq, Show)
159319
160320typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
161321typeVal (TypeContext tv) x
162− | S.null matches = Just (TypeValidatorInvalid tv x)
163− | otherwise = Nothing
322+ | Set.null matches = Just (TypeValidatorInvalid tv x)
323+ | otherwise = Nothing
164324 where
165325 -- There can be more than one match because a 'Value' can be both a
166326 -- @"number"@ and an @"integer"@.
167− matches :: Set Text
168− matches = S.intersection okTypes (setFromTypeValidator tv)
327+ matches :: Set SchemaType
328+ matches = Set.intersection okTypes (setFromTypeValidator tv)
169329
170− okTypes :: Set Text
330+ okTypes :: Set SchemaType
171331 okTypes =
172332 case x of
173− Null -> S.singleton "null"
174− (Array _) -> S.singleton "array"
175− (Bool _) -> S.singleton "boolean"
176− (Object _) -> S.singleton "object"
177− (String _) -> S.singleton "string"
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
178338 (Number y) ->
179339 if SCI.isInteger y
180− then S.fromList ["number", "integer"]
181− else S.singleton "number"
340+ then Set.fromList [SchemaNumber, SchemaInteger]
341+ else Set.singleton SchemaNumber
182342
183343-- | Internal.
184−setFromTypeValidator :: TypeValidator -> Set Text
185−setFromTypeValidator (TypeValidatorString t) = S.singleton t
344+setFromTypeValidator :: TypeValidator -> Set SchemaType
345+setFromTypeValidator (TypeValidatorString t) = Set.singleton t
186346setFromTypeValidator (TypeValidatorArray ts) = ts
187347
188348--------------------------------------------------
@@ -239,8 +399,7 @@ anyOfVal
239399 -> Value
240400 -> Maybe (AnyOfInvalid err)
241401anyOfVal f (AnyOf subSchemas) x
242− -- Replace with @null@ once we drop GHC 7.8:
243− | any (((==) 0 . length) . snd) perhapsFailures = Nothing
402+ | any (null . snd) perhapsFailures = Nothing
244403 | otherwise = AnyOfInvalid <$> NE.nonEmpty failures
245404 where
246405 perhapsFailures :: [(JP.Index, [err])]