23ef711 · typeable/hjsonschema

git.iko.soy/typeable/hjsonschema

Fix fetching of remote schemas.

Before when `fetchRefs` searched through a schema for "$refs", it assumed every object in the schema's JSON was a valid subschema. This is not the case (for instance "definitions" will be an object, but that object's _members_ are subschemas, not the object itself. This is now fixed so that only actual subschemas are checked for "refs".

commit23ef711e93b9748ca59dcc91438818d01dfc76b6 authorIan Grant Jeffries <ian@housejeffries.com> dateFri 13 Feb 2015, 21:02 (12 years ago) parent79fc9f1

6 files changed+81−52

compare with master

unifiedsplit

README.md+1−1 hjsonschema.cabal+1−1 src/Data/JsonSchema.hs+37−42 src/Data/JsonSchema/Core.hs+5−3 src/Data/JsonSchema/Validators.hs+35−3 tests/Lib.hs+2−2

README.md+1−1

@@ -6,7 +6,7 @@ An implementation of [JSON Schema](http://json-schema.org/) v4 in haskell.

77Still in development. Lacks documentation, example code, and real error messages.

9−Also while all the official tests pass, its implementation of the `$ref` and `id` keywords is incomplete.

9+Also while the official tests pass, its handling of the `id` keyword is incomplete.

1010

1111# Install Tests

1212

hjsonschema.cabal+1−1

@@ -1,5 +1,5 @@

11name: hjsonschema

2−version: 0.1.1.0

2+version: 0.2.0.0

33synopsis: Haskell implementation of JSON Schema v4.

44homepage: https://github.com/seagreen/hjsonschema

55license: MIT

src/Data/JsonSchema.hs+37−42

@@ -4,7 +4,6 @@ module Data.JsonSchema

44 ) where

66import Control.Applicative

7−import Data.Aeson

87import Data.Foldable

98import qualified Data.HashMap.Strict as H

109import Data.JsonSchema.Core

@@ -12,7 +11,6 @@ import Data.JsonSchema.JsonReference

1211import Data.JsonSchema.Utils

1312import Data.JsonSchema.Validators

1413import Data.Maybe

15−import Data.Text (Text)

1614import qualified Data.Text as T

1715import Data.Vector (Vector)

1816import qualified Data.Vector as V

@@ -20,50 +18,47 @@ import Prelude hiding (foldr)

2018

2119draft4 :: Spec

2220draft4 = Spec $ H.fromList

23− [ ("$ref", ref)

24− , ("multipleOf", multipleOf)

25− , ("maximum", maximumVal)

26− , ("minimum", minimumVal)

27− , ("maxLength", maxLength)

28− , ("minLength", minLength)

29− , ("pattern", pattern)

30− , ("items", items)

31− , ("maxItems", maxItems)

32− , ("minItems", minItems)

33− , ("uniqueItems", uniqueItems)

34− , ("maxProperties", maxProperties)

35− , ("minProperties", minProperties)

36− , ("required", required)

37− , ("properties", properties)

38− , ("patternProperties", patternProperties)

39− , ("additionalProperties", additionalProperties)

40− , ("dependencies", dependencies)

41− , ("enum", enum)

42− , ("type", typeVal)

43− , ("allOf", allOf)

44− , ("anyOf", anyOf)

45− , ("oneOf", oneOf)

46− , ("not", notValidator)

21+ [ ("$ref" , (ref , noEm))

22+ , ("multipleOf" , (multipleOf , noEm))

23+ , ("maximum" , (maximumVal , noEm))

24+ , ("minimum" , (minimumVal , noEm))

25+ , ("maxLength" , (maxLength , noEm))

26+ , ("minLength" , (minLength , noEm))

27+ , ("pattern" , (pattern , noEm))

28+ , ("additionalItems" , (noVal , objEmbed))

29+ , ("items" , (items , objOrArrayEmbed))

30+ , ("maxItems" , (maxItems , noEm))

31+ , ("minItems" , (minItems , noEm))

32+ , ("uniqueItems" , (uniqueItems , noEm))

33+ , ("maxProperties" , (maxProperties , noEm))

34+ , ("minProperties" , (minProperties , noEm))

35+ , ("required" , (required , noEm))

36+ , ("properties" , (properties , objMembersEmbed))

37+ , ("patternProperties" , (patternProperties , objMembersEmbed))

38+ , ("additionalProperties", (additionalProperties, objEmbed))

39+ , ("dependencies" , (dependencies , objMembersEmbed))

40+ , ("enum" , (enum , noEm))

41+ , ("type" , (typeVal , noEm))

42+ , ("allOf" , (allOf , arrayEmbed))

43+ , ("anyOf" , (anyOf , arrayEmbed))

44+ , ("oneOf" , (oneOf , arrayEmbed))

45+ , ("not" , (notValidator , objEmbed))

46+ , ("definitions" , (noVal , objMembersEmbed))

4747 ]

4848

49−fetchRefs :: RawSchema -> Graph -> IO Graph

50−fetchRefs a graph =

51− let newGraph = H.insert (_rsURI a) (_rsObject a) graph

52− rSchema = allEmbedded (_rsURI a, Object $ _rsObject a) V.empty

53− in foldlM fetch newGraph rSchema

49+fetchRefs :: Spec -> RawSchema -> Graph -> IO Graph

50+fetchRefs spec a graph =

51+ let startingGraph = H.insert (_rsURI a) (_rsObject a) graph

52+ in foldlM fetch startingGraph (includeEmbedded a)

5453

5554 where

5655 -- TODO: optimize

57− allEmbedded :: (Text, Value) -> Vector RawSchema -> Vector RawSchema

58− allEmbedded (t, Object o) rs =

59− let t' = updateId t o

60− r = RawSchema t' o

61− ns = (\x -> (t',x)) <$> V.fromList (H.elems o)

62− in foldr allEmbedded (V.snoc rs r) ns

63− allEmbedded (t, Array vs) rs =

64− let ns = (\x -> (t,x)) <$> vs

65− in foldr allEmbedded rs ns

66− allEmbedded _ rs = rs

56+ includeEmbedded :: RawSchema -> Vector RawSchema

57+ includeEmbedded r =

58+ let newId = updateId (_rsURI r) (_rsObject r)

59+ xs = H.intersectionWith (\(_,f) x -> f newId x) (_unSpec spec) (_rsObject r)

60+ ys = V.concat . H.elems $ xs

61+ in V.cons r . V.concat . V.toList $ includeEmbedded <$> ys

6762

6863 fetch :: Graph -> RawSchema -> IO Graph

6964 fetch g r =

@@ -76,5 +71,5 @@ fetchRefs a graph =

7671 else do

7772 eResp <- fetchRef t

7873 case eResp of

79− Right obj -> fetchRefs (RawSchema t obj) g

74+ Right obj -> fetchRefs spec (RawSchema t obj) g

8075 _ -> return g

src/Data/JsonSchema/Core.hs+5−3

@@ -9,7 +9,9 @@ import Data.Text (Text)

99import Data.Vector (Vector)

1010import qualified Data.Vector as V

1111

12−newtype Spec = Spec { _unSpec :: HashMap Text ValidatorGen }

12+newtype Spec = Spec

13+ { _unSpec :: HashMap Text (ValidatorGen, Text -> Value -> Vector RawSchema)

14+ }

1315

1416-- | Set of potentially mutually recursive schemas.

1517type Graph = HashMap Text (HashMap Text Value)

@@ -31,8 +33,8 @@ compile :: Spec -> Graph -> RawSchema -> Schema

3133compile spec g (RawSchema t o) =

3234 V.fromList . catMaybes . H.elems $ H.intersectionWith f (_unSpec spec) o

3335 where

34− f :: ValidatorGen -> Value -> Maybe Validator

35− f vGen = vGen spec g $ RawSchema (updateId t o) o

36+ f :: (ValidatorGen, a) -> Value -> Maybe Validator

37+ f (vGen,_) = vGen spec g $ RawSchema (updateId t o) o

3638

3739validate :: Schema -> Value -> Vector ValErr

3840validate s x = s >>= ($ x)

src/Data/JsonSchema/Validators.hs+35−3

@@ -8,11 +8,15 @@

88-- This module exposes three types of functions. To describe

99-- them we'll use the properties validators as an example.

1010--

11−-- 1. Functions that aren't followed by apostrophes have the

11+-- 1. Functions which describe how subschemas (if any)

12+-- are embedded in this validator. This is how 'fetchRefs'

13+-- is able to find "$refs" and "ids".

14+--

15+-- 2. Functions that aren't followed by apostrophes have the

1216-- type 'ValidatorGen' and are meant to be used in a 'Spec'.

1317-- Examples are 'properties' and 'additionalProperties'.

1418--

15−-- 2. Functions that are followed by a single apostrophe, such

19+-- 3. Functions that are followed by a single apostrophe, such

1620-- as 'additionalProperties'', aren't meant to be used standalone

1721-- in a 'Spec'. Instead they're used by other validators. For

1822-- instance, 'additionalProperties' disables itself if the key

@@ -21,7 +25,7 @@

2125-- 'additionalProperties' in 'additionalProperties'' allows for

2226-- code reuse between 'properties' and 'additionalProperties'.

2327--

24−-- 3. Functions that are followed by a double apostrophe, such

28+-- 4. Functions that are followed by a double apostrophe, such

2529-- as 'patternProperties''', return an enhanced validator. It

2630-- not only reports errors, but also the parts of the target

2731-- data that it matches. These functions also aren't used in

@@ -49,6 +53,31 @@ import Data.Vector (Vector)

4953import qualified Data.Vector as V

5054import Text.RegexPR

5155

56+--------------------------------------------------

57+-- Embedded Schema Layouts

58+--------------------------------------------------

59+

60+noEm :: Text -> Value -> Vector RawSchema

61+noEm _ _ = V.empty

62+

63+objEmbed :: Text -> Value -> Vector RawSchema

64+objEmbed t (Object o) = V.singleton $ RawSchema t o

65+objEmbed _ _ = V.empty

66+

67+-- TODO: optimize

68+arrayEmbed :: Text -> Value -> Vector RawSchema

69+arrayEmbed t (Array vs) = V.concat . V.toList $ (\o -> objEmbed t o) <$> vs

70+arrayEmbed _ _ = V.empty

71+

72+objOrArrayEmbed :: Text -> Value -> Vector RawSchema

73+objOrArrayEmbed t v@(Object _) = objEmbed t v

74+objOrArrayEmbed t v@(Array _) = arrayEmbed t v

75+objOrArrayEmbed _ _ = V.empty

76+

77+objMembersEmbed :: Text -> Value -> Vector RawSchema

78+objMembersEmbed t (Object o) = V.concat $ (\x -> objEmbed t x) <$> H.elems o

79+objMembersEmbed _ _ = V.empty

80+

5281--------------------------------------------------

5382-- Number Validators

5483--------------------------------------------------

@@ -495,3 +524,6 @@ ref spec g s (String val) = do

495524 (Object o) -> Just $ RawSchema (_rsURI rawS) o

496525 _ -> Nothing

497526ref _ _ _ _ = Nothing

527+

528+noVal :: ValidatorGen

529+noVal = (\_ _ _ _ -> Just (const V.empty))

tests/Lib.hs+2−2

@@ -82,11 +82,11 @@ toTest st = testGroup groupName (mkCase <$> _stCases st)

8282

8383assertValid, assertInvalid :: RawSchema -> Value -> HU.Assertion

8484assertValid r v = do

85− g <- fetchRefs r H.empty

85+ g <- fetchRefs draft4 r H.empty

8686 let es = validate (compile draft4 g r) v

8787 unless (V.length es == 0) $ HU.assertFailure (show es)

8888assertInvalid r v = do

89− g <- fetchRefs r H.empty

89+ g <- fetchRefs draft4 r H.empty

9090 let es = validate (compile draft4 g r) v

9191 when (V.length es == 0) $ HU.assertFailure "expected a validation error"

9292