0ccad44 · typeable/hjsonschema

README.md+2−2

@@ -52,9 +52,9 @@ Run remote tests (makes GETs to json-schema.org, also temporarily starts an HTTP

5252

5353## Vendoring

5454

55−+ `JSON-Schema-Test-Suite` is vendored from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite).

55++ `JSON-Schema-Test-Suite` is vendored from commit # c1b12bf699f29a04b4286711c6e3bbfba66f21e5 [here](https://github.com/json-schema-org/JSON-Schema-Test-Suite).

5656

57−+ `src/draft4.json` is from commit # f3d5aeb5ffbe9d9a5a0ceb761dc47c7c4c2efa68 [here](https://github.com/json-schema/json-schema).

57++ `src/draft4.json` is from commit # aabcb3427745ade7a0b4d49ff016ad7eda8b898b [here](https://github.com/json-schema/json-schema).

5858

5959## Credits

6060

examples/AlternateSchema.hs+77−43

@@ -19,13 +19,15 @@ import Data.Profunctor (Profunctor (..))

1919

2020import JSONSchema.Draft4 (ValidatorFailure(..),

2121 metaSchemaBytes)

22−import JSONSchema.Fetch (ReferencedSchemas(..),

23− SchemaWithURI(..))

22+import JSONSchema.Fetch (SchemaWithURI(..),

23+ URISchemaMap(..))

2424import qualified JSONSchema.Fetch as FE

2525import JSONSchema.Types (Schema(..), Spec(..))

2626import qualified JSONSchema.Types as JT

2727import qualified JSONSchema.Validator.Draft4 as D4

28−import JSONSchema.Validator.Reference (updateResolutionScope)

28+import JSONSchema.Validator.Reference (BaseURI(..),

29+ Scope(..),

30+ updateResolutionScope)

2931

3032--------------------------------------------------

3133-- * Basic fetching tools

@@ -45,22 +47,38 @@ draft4FetchInfo = FE.FetchInfo embedded (lookup "id") (lookup "$ref")

4547 Just (String t) -> Just t

4648 _ -> Nothing

4749

50+-- | An implementation of 'JT.embedded'.

4851embedded :: Schema -> ([Schema], [Schema])

49−embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s

52+embedded s =

53+ JT.embedded (d4Spec mempty mempty (Scope s Nothing (BaseURI Nothing))) s

5054

5155--------------------------------------------------

5256-- * Main API

5357--------------------------------------------------

5458

5559validate

56− :: ReferencedSchemas Schema

57− -> Maybe Text

58− -> Schema

60+ :: URISchemaMap Schema

61+ -> SchemaWithURI Schema

5962 -> Value

6063 -> [ValidatorFailure]

61−validate rs = continueValidating rs (D4.VisitedSchemas [(Nothing, Nothing)])

64+validate schemaMap sw =

65+ JT.validate (d4Spec schemaMap visited scope) (_swSchema sw)

66+ where

67+ visited :: D4.VisitedSchemas

68+ visited = D4.VisitedSchemas [(Nothing, Nothing)]

69+

70+ schemaId :: Maybe Text

71+ schemaId = FE._fiId draft4FetchInfo (_swSchema sw)

6272

63−-- A schema for schemas themselves, using @src/draft4.json@ which is loaded

73+ scope :: Scope Schema

74+ scope = Scope

75+ { _topLevelDocument = _swSchema sw

76+ , _documentURI = _swURI sw

77+ , _currentBaseURI = updateResolutionScope (BaseURI (_swURI sw))

78+ schemaId

79+ }

80+

81+-- | A schema for schemas themselves. Uses @src/draft4.json@ which is loaded

6482-- at compile time.

6583metaSchema :: Schema

6684metaSchema =

@@ -69,47 +87,57 @@ metaSchema =

6987 $ metaSchemaBytes

7088

7189checkSchema :: Schema -> [ValidatorFailure]

72−checkSchema = validate referenced Nothing metaSchema . Object . _unSchema

90+checkSchema = validate schemaMap (SchemaWithURI metaSchema Nothing)

91+ . Object

92+ . _unSchema

7393 where

74− referenced :: ReferencedSchemas Schema

75− referenced = ReferencedSchemas

76− metaSchema

77− (HM.singleton "http://json-schema.org/draft-04/schema"

94+ schemaMap :: URISchemaMap Schema

95+ schemaMap =

96+ URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema"

7897 metaSchema)

7998

8099--------------------------------------------------

81100-- * Spec

82101--------------------------------------------------

83102

84−continueValidating

85− :: ReferencedSchemas Schema

103+validateSubschema

104+ :: URISchemaMap Schema

86105 -> D4.VisitedSchemas

87− -> Maybe Text

106+ -> Scope Schema

88107 -> Schema

89108 -> Value

90109 -> [ValidatorFailure]

91−continueValidating referenced visited mURI sc =

92− JT.validate (d4Spec referenced visited newScope) sc

110+validateSubschema schemaMap visited scope schema =

111+ JT.validate (d4Spec schemaMap visited newScope) schema

93112 where

94113 schemaId :: Maybe Text

95− schemaId = case HM.lookup "id" (_unSchema sc) of

96− Just (String t) -> Just t

97− _ -> Nothing

114+ schemaId = FE._fiId draft4FetchInfo schema

98115

99− newScope :: Maybe Text

100− newScope = updateResolutionScope mURI schemaId

116+ newScope :: Scope Schema

117+ newScope = scope

118+ { _currentBaseURI = updateResolutionScope (_currentBaseURI scope)

119+ schemaId

120+ }

101121

102122d4Spec

103− :: ReferencedSchemas Schema

123+ :: URISchemaMap Schema

104124 -> D4.VisitedSchemas

105− -> Maybe Text

125+ -> Scope Schema

106126 -> Spec Schema ValidatorFailure

107127 -- ^ Here we reuses 'ValidatorFailure' from

108128 -- 'JSONSchema.Draft4.Failure'. If your validators have different

109129 -- failure possibilities you'll need to create your own validator

110130 -- failure type.

111−d4Spec referenced visited scope =

112− Spec

131+d4Spec schemaMap visited scope =

132+ Spec $

133+ [ dimap

134+ f

135+ FailureRef

136+ (D4.refValidator (FE.getReference schemaMap) updateScope

137+ valRef visited scope)

138+ ]

139+

140+ <> fmap (lmap disableIfRefPresent)

113141 [ dimap f FailureMultipleOf D4.multipleOfValidator

114142 , dimap f FailureMaximum D4.maximumValidator

115143 , dimap f FailureMinimum D4.minimumValidator

@@ -127,6 +155,7 @@ d4Spec referenced visited scope =

127155 D4.IRInvalidItems e -> FailureItems e

128156 D4.IRInvalidAdditional e -> FailureAdditionalItems e)

129157 (D4.itemsRelatedValidator descend)

158+ , lmap f D4.definitionsEmbedded

130159

131160 , dimap f FailureMaxProperties D4.maxPropertiesValidator

132161 , dimap f FailureMinProperties D4.minPropertiesValidator

@@ -137,10 +166,6 @@ d4Spec referenced visited scope =

137166 FailurePropertiesRelated

138167 (D4.propertiesRelatedValidator descend)

139168

140− , dimap

141− f

142− FailureRef

143− (D4.refValidator visited scope (FE.getReference referenced) getRef)

144169 , dimap f FailureEnum D4.enumValidator

145170 , dimap f FailureType D4.typeValidator

146171 , dimap f FailureAllOf (D4.allOfValidator lateral)

@@ -150,22 +175,31 @@ d4Spec referenced visited scope =

150175 ]

151176 where

152177 f :: FromJSON a => Schema -> Maybe a

153− f (Schema a) = case AE.fromJSON (Object a) of

154− AE.Error _ -> Nothing

155− AE.Success b -> Just b

156−

157− -- 'Maybe Text' is the URI the referenced schema is fetched from,

158− -- this probably needs a 'newtype' wrapper.

159− getRef

178+ f (Schema a) =

179+ case AE.fromJSON (Object a) of

180+ AE.Error _ -> Nothing

181+ AE.Success b -> Just b

182+

183+ disableIfRefPresent :: Schema -> Schema

184+ disableIfRefPresent schema =

185+ case FE._fiRef draft4FetchInfo schema of

186+ Nothing -> schema

187+ Just _ -> Schema mempty

188+

189+ updateScope :: BaseURI -> Schema -> BaseURI

190+ updateScope uri schema =

191+ updateResolutionScope uri (FE._fiId draft4FetchInfo schema)

192+

193+ valRef

160194 :: D4.VisitedSchemas

161− -> Maybe Text

195+ -> Scope Schema

162196 -> Schema

163197 -> Value

164198 -> [ValidatorFailure]

165− getRef = continueValidating referenced

199+ valRef vis sc = JT.validate (d4Spec schemaMap vis sc)

166200

167201 descend :: Schema -> Value -> [ValidatorFailure]

168− descend = continueValidating referenced mempty scope

202+ descend = validateSubschema schemaMap mempty scope

169203

170204 lateral :: Schema -> Value -> [ValidatorFailure]

171− lateral = continueValidating referenced visited scope

205+ lateral = validateSubschema schemaMap visited scope

src/Import.hs+9−1

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

11

2−module Import (module Export) where

2+module Import (module Export, fromJSONEither) where

33

44import Protolude as Export

55

@@ -10,3 +10,11 @@ import Data.List.NonEmpty as Export (NonEmpty)

1010import Data.Vector as Export (Vector)

1111import Test.QuickCheck as Export hiding ((.&.), Failure,

1212 Result, Success)

13+

14+import qualified Data.Text as T

15+

16+fromJSONEither :: FromJSON a => Value -> Either Text a

17+fromJSONEither a =

18+ case fromJSON a of

19+ Error e -> Left (T.pack e)

20+ Success b -> Right b

src/JSONSchema/Draft4.hs+12−18

@@ -22,8 +22,7 @@ module JSONSchema.Draft4

2222 , ValidatorFailure(..)

2323

2424 -- * Fetching tools

25− , ReferencedSchemas(..)

26− , FE.URISchemaMap(..)

25+ , URISchemaMap(..)

2726 , referencesViaHTTP

2827 , referencesViaFilesystem

2928

@@ -38,7 +37,6 @@ module JSONSchema.Draft4

3837

3938import Import

4039

41−import Control.Arrow (left)

4240import qualified Data.ByteString as BS

4341import Data.FileEmbed (embedFile,

4442 makeRelativeToProject)

@@ -52,8 +50,8 @@ import JSONSchema.Draft4.Failure (Invalid(..),

5250import JSONSchema.Draft4.Schema (Schema)

5351import qualified JSONSchema.Draft4.Schema as SC

5452import qualified JSONSchema.Draft4.Spec as Spec

55−import JSONSchema.Fetch (ReferencedSchemas(..),

56− SchemaWithURI(..))

53+import JSONSchema.Fetch (SchemaWithURI(..),

54+ URISchemaMap(..))

5755import qualified JSONSchema.Fetch as FE

5856

5957data HTTPValidationFailure

@@ -70,11 +68,11 @@ fetchHTTPAndValidate

7068 -> IO (Either HTTPValidationFailure ())

7169fetchHTTPAndValidate sw v = do

7270 res <- referencesViaHTTP sw

73− pure (g =<< f =<< left HVRequest res)

71+ pure (g =<< f =<< first HVRequest res)

7472 where

7573 f :: FE.URISchemaMap Schema

7674 -> Either HTTPValidationFailure (Value -> [ValidatorFailure])

77− f references = left HVSchema (checkSchema references sw)

75+ f references = first HVSchema (checkSchema references sw)

7876

7977 g :: (Value -> [ValidatorFailure]) -> Either HTTPValidationFailure ()

8078 g val = case NE.nonEmpty (val v) of

@@ -100,11 +98,11 @@ fetchFilesystemAndValidate

10098 -> IO (Either FilesystemValidationFailure ())

10199fetchFilesystemAndValidate sw v = do

102100 res <- referencesViaFilesystem sw

103− pure (g =<< f =<< left FVRead res)

101+ pure (g =<< f =<< first FVRead res)

104102 where

105103 f :: FE.URISchemaMap Schema

106104 -> Either FilesystemValidationFailure (Value -> [ValidatorFailure])

107− f references = left FVSchema (checkSchema references sw)

105+ f references = first FVSchema (checkSchema references sw)

108106

109107 g :: (Value -> [ValidatorFailure]) -> Either FilesystemValidationFailure ()

110108 g val = case NE.nonEmpty (val v) of

@@ -143,10 +141,7 @@ checkSchema

143141checkSchema sm sw =

144142 case NE.nonEmpty failures of

145143 Just fs -> Left (SchemaInvalid fs)

146− Nothing -> Right (Spec.specValidate

147− (ReferencedSchemas (_swSchema sw)

148− (FE._unURISchemaMap sm))

149− sw)

144+ Nothing -> Right (Spec.specValidate sm sw)

150145 where

151146 failures :: [(Maybe Text, NonEmpty ValidatorFailure)]

152147 failures =

@@ -169,12 +164,11 @@ metaSchemaBytes =

169164-- (if so the returned list will be empty).

170165schemaValidity :: Schema -> [ValidatorFailure]

171166schemaValidity =

172− Spec.specValidate referenced (SchemaWithURI metaSchema Nothing) . toJSON

167+ Spec.specValidate schemaMap (SchemaWithURI metaSchema Nothing) . toJSON

173168 where

174− referenced :: ReferencedSchemas Schema

175− referenced = ReferencedSchemas

176− metaSchema

177− (HM.singleton "http://json-schema.org/draft-04/schema"

169+ schemaMap :: URISchemaMap Schema

170+ schemaMap =

171+ URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema"

178172 metaSchema)

179173

180174-- | Check that a set of referenced schemas are valid

src/JSONSchema/Draft4/Spec.hs+59−33

@@ -7,47 +7,71 @@ import Data.Maybe (fromMaybe)

77import Data.Profunctor (Profunctor(..))

88

99import JSONSchema.Draft4.Failure

10−import JSONSchema.Draft4.Schema (Schema(..))

11−import JSONSchema.Fetch (ReferencedSchemas(..),

12− SchemaWithURI(..))

10+import JSONSchema.Draft4.Schema (Schema(..),

11+ emptySchema)

12+import JSONSchema.Fetch (SchemaWithURI(..),

13+ URISchemaMap(..))

1314import qualified JSONSchema.Fetch as FE

1415import JSONSchema.Types (Spec(..))

1516import qualified JSONSchema.Types as JT

1617import JSONSchema.Validator.Draft4

17−import JSONSchema.Validator.Reference (updateResolutionScope)

18+import JSONSchema.Validator.Reference (BaseURI(..),

19+ Scope(..),

20+ updateResolutionScope)

1821

22+-- | An implementation of 'JT.embedded'.

1923embedded :: Schema -> ([Schema], [Schema])

20−embedded s = JT.embedded (d4Spec (ReferencedSchemas s mempty) mempty Nothing) s

24+embedded s =

25+ JT.embedded (d4Spec mempty mempty (Scope s Nothing (BaseURI Nothing))) s

2126

2227specValidate

23− :: ReferencedSchemas Schema

28+ :: URISchemaMap Schema

2429 -> SchemaWithURI Schema

2530 -> Value

2631 -> [ValidatorFailure]

27−specValidate rs =

28− continueValidating rs (VisitedSchemas [(Nothing, Nothing)])

32+specValidate schemaMap sw =

33+ JT.validate (d4Spec schemaMap visited scope) (_swSchema sw)

34+ where

35+ visited :: VisitedSchemas

36+ visited = VisitedSchemas [(Nothing, Nothing)]

37+

38+ scope :: Scope Schema

39+ scope = Scope

40+ { _topLevelDocument = _swSchema sw

41+ , _documentURI = _swURI sw

42+ , _currentBaseURI = updateResolutionScope (BaseURI (_swURI sw))

43+ (_schemaId (_swSchema sw))

44+ }

2945

30−continueValidating

31− :: ReferencedSchemas Schema

46+validateSubschema

47+ :: URISchemaMap Schema

3248 -> VisitedSchemas

33− -> SchemaWithURI Schema

49+ -> Scope Schema

50+ -> Schema

3451 -> Value

3552 -> [ValidatorFailure]

36−continueValidating referenced visited sw =

37− JT.validate (d4Spec referenced visited currentScope)

38− (_swSchema sw)

53+validateSubschema schemaMap visited scope schema =

54+ JT.validate (d4Spec schemaMap visited newScope) schema

3955 where

40− currentScope :: Maybe Text

41− currentScope = updateResolutionScope

42− (_swURI sw)

43− (_schemaId (_swSchema sw))

56+ newScope :: Scope Schema

57+ newScope = scope

58+ { _currentBaseURI = updateResolutionScope (_currentBaseURI scope)

59+ (_schemaId schema)

60+ }

4461

4562d4Spec

46− :: ReferencedSchemas Schema

63+ :: URISchemaMap Schema

4764 -> VisitedSchemas

48− -> Maybe Text

65+ -> Scope Schema

4966 -> Spec Schema ValidatorFailure

50−d4Spec referenced visited scope = Spec

67+d4Spec schemaMap visited scope = Spec $

68+ [ dimap

69+ (fmap Ref . _schemaRef)

70+ FailureRef

71+ (refValidator (FE.getReference schemaMap) updateScope valRef visited scope)

72+ ]

73+

74+ <> fmap (lmap disableIfRefPresent)

5175 [ dimap (fmap MultipleOf . _schemaMultipleOf) FailureMultipleOf multipleOfValidator

5276 , dimap

5377 (\s -> Maximum (fromMaybe False (_schemaExclusiveMaximum s)) <$> _schemaMaximum s)

@@ -98,10 +122,6 @@ d4Spec referenced visited scope = Spec

98122 FailurePropertiesRelated

99123 (propertiesRelatedValidator descend)

100124

101− , dimap

102− (\s -> Ref <$> _schemaRef s)

103− FailureRef

104− (refValidator visited scope (FE.getReference referenced) getRef)

105125 , dimap (fmap EnumValidator . _schemaEnum) FailureEnum enumValidator

106126 , dimap (fmap TypeContext . _schemaType) FailureType typeValidator

107127 , dimap (fmap AllOf . _schemaAllOf) FailureAllOf (allOfValidator lateral)

@@ -110,19 +130,25 @@ d4Spec referenced visited scope = Spec

110130 , dimap (fmap NotValidator . _schemaNot) FailureNot (notValidator lateral)

111131 ]

112132 where

113− getRef

133+ disableIfRefPresent :: Schema -> Schema

134+ disableIfRefPresent schema =

135+ case _schemaRef schema of

136+ Nothing -> schema

137+ Just _ -> emptySchema

138+

139+ updateScope :: BaseURI -> Schema -> BaseURI

140+ updateScope uri schema = updateResolutionScope uri (_schemaId schema)

141+

142+ valRef

114143 :: VisitedSchemas

115− -> Maybe Text

144+ -> Scope Schema

116145 -> Schema

117146 -> Value

118147 -> [ValidatorFailure]

119− getRef newVisited newScope schema =

120− continueValidating referenced newVisited (SchemaWithURI schema newScope)

148+ valRef vis sc = JT.validate (d4Spec schemaMap vis sc)

121149

122150 descend :: Schema -> Value -> [ValidatorFailure]

123− descend schema =

124− continueValidating referenced mempty (SchemaWithURI schema scope)

151+ descend = validateSubschema schemaMap mempty scope

125152

126153 lateral :: Schema -> Value -> [ValidatorFailure]

127− lateral schema =

128− continueValidating referenced visited (SchemaWithURI schema scope)

154+ lateral = validateSubschema schemaMap visited scope

src/JSONSchema/Fetch.hs+35−55

@@ -3,7 +3,6 @@ module JSONSchema.Fetch where

33

44import Import

55

6−import Control.Arrow (left)

76import Control.Exception (IOException, catch)

87import Control.Monad (foldM)

98import qualified Data.ByteString as BS

@@ -12,7 +11,8 @@ import qualified Data.HashMap.Strict as HM

1211import qualified Data.Text as T

1312import qualified Network.HTTP.Client as NC

1413

15−import JSONSchema.Validator.Reference (resolveReference,

14+import JSONSchema.Validator.Reference (BaseURI(..),

15+ resolveReference,

1616 updateResolutionScope)

1717

1818--------------------------------------------------

@@ -27,49 +27,22 @@ data FetchInfo schema = FetchInfo

2727 , _fiRef :: schema -> Maybe Text

2828 }

2929

30−data ReferencedSchemas schema = ReferencedSchemas

31− { _rsStarting :: !schema

32− -- ^ Used to resolve relative references when we don't know what the scope

33− -- of the current schema is. This only happens with starting schemas

34− -- because if we're using a remote schema we had to know its URI in order

35− -- to fetch it.

36− --

37− -- Tracking the starting schema (instead of just resolving the reference to

38− -- the current schema being used for validation) is necessary for cases

39− -- where schemas are embedded inside one another. For instance in this

40− -- case not distinguishing the starting and "foo" schemas sends the code

41− -- into an infinite loop:

42− --

43− -- {

44− -- "additionalProperties": false,

45− -- "properties": {

46− -- "foo": {

47− -- "$ref": "#"

48− -- }

49− -- }

50− -- }

51− , _rsSchemaMap :: !(HashMap Text schema)

52− -- ^ Map of URIs to schemas.

53− } deriving (Eq, Show)

54−

5530-- | Keys are URIs (without URI fragments).

5631newtype URISchemaMap schema

5732 = URISchemaMap { _unURISchemaMap :: HashMap Text schema }

58− deriving (Eq, Show)

33+ deriving (Eq, Show, Monoid)

5934

35+-- | A top-level schema along with its location.

6036data SchemaWithURI schema = SchemaWithURI

6137 { _swSchema :: !schema

6238 , _swURI :: !(Maybe Text)

63− -- ^ This is the URI identifying the document containing the schema.

39+ -- ^ This is the URI from which the document was originally fetched.

6440 -- It's different than the schema's "id" field, which controls scope

6541 -- when resolving references contained in the schema.

66−

67− -- TODO: Make the no URI fragment requirement unnecessary.

6842 } deriving (Eq, Show)

6943

70−getReference :: ReferencedSchemas schema -> Maybe Text -> Maybe schema

71−getReference referenced Nothing = Just (_rsStarting referenced)

72−getReference referenced (Just t) = HM.lookup t (_rsSchemaMap referenced)

44+getReference :: URISchemaMap schema -> Text -> Maybe schema

45+getReference schemaMap t = HM.lookup t (_unURISchemaMap schemaMap)

7346

7447--------------------------------------------------

7548-- * Fetch via HTTP

@@ -90,7 +63,7 @@ referencesViaHTTP'

9063referencesViaHTTP' info sw = do

9164 manager <- NC.newManager NC.defaultManagerSettings

9265 let f = referencesMethodAgnostic (getURL manager) info sw

93− catch (left HTTPParseFailure <$> f) handler

66+ catch (first HTTPParseFailure <$> f) handler

9467 where

9568 getURL :: NC.Manager -> Text -> IO BS.ByteString

9669 getURL man url = do

@@ -116,7 +89,7 @@ referencesViaFilesystem'

11689 => FetchInfo schema

11790 -> SchemaWithURI schema

11891 -> IO (Either FilesystemFailure (URISchemaMap schema))

119−referencesViaFilesystem' info sw = catch (left FSParseFailure <$> f) handler

92+referencesViaFilesystem' info sw = catch (first FSParseFailure <$> f) handler

12093 where

12194 f :: IO (Either Text (URISchemaMap schema))

12295 f = referencesMethodAgnostic (BS.readFile . T.unpack) info sw

@@ -155,27 +128,33 @@ getRecursiveReferences fetchRef info referenced sw =

155128 f :: Either Text (URISchemaMap schema)

156129 -> SchemaWithURI schema

157130 -> IO (Either Text (URISchemaMap schema))

158− f (Left e) _ = pure (Left e)

159− f (Right (URISchemaMap usm)) (SchemaWithURI schema mUri) =

131+ f (Left e) _ = pure (Left e)

132+ f (Right (URISchemaMap schemaMap)) (SchemaWithURI schema mURI) =

160133 case newRef of

161− Nothing -> pure (Right (URISchemaMap usm))

134+ Nothing -> pure (Right (URISchemaMap schemaMap))

162135 Just uri -> do

163136 bts <- fetchRef uri

164137 case eitherDecodeStrict bts of

165− Left e -> pure . Left . T.pack $ e

166− Right schm -> getRecursiveReferences

167− fetchRef

168− info

169− (URISchemaMap (HM.insert uri schm usm))

170− (SchemaWithURI schm (Just uri))

138+ Left e -> pure . Left . T.pack $ e

139+ Right s -> getRecursiveReferences

140+ fetchRef

141+ info

142+ (URISchemaMap (HM.insert uri s schemaMap))

143+ (SchemaWithURI s (Just uri))

171144 where

172145 newRef :: Maybe Text

173− newRef

174− | Just (Just uri,_) <- resolveReference mUri <$> _fiRef info schema

175− = case HM.lookup uri usm of

176− Nothing -> Just uri

177− Just _ -> Nothing

178− | otherwise = Nothing

146+ newRef = do

147+ ref <- _fiRef info schema

148+

149+ -- Consider the reference before updating the scope.

150+ -- If it's a only a fragment this isn't referencing

151+ -- a new document.

152+ void (fst (resolveReference (BaseURI Nothing) ref))

153+

154+ uri <- fst (resolveReference (BaseURI mURI) ref)

155+ case HM.lookup uri schemaMap of

156+ Nothing -> Just uri

157+ Just _ -> Nothing

179158

180159-- | Return the schema passed in as an argument, as well as every

181160-- subschema contained within it.

@@ -184,11 +163,12 @@ includeSubschemas

184163 FetchInfo schema

185164 -> SchemaWithURI schema

186165 -> [SchemaWithURI schema]

187−includeSubschemas info (SchemaWithURI schema mUri) =

188− SchemaWithURI schema mUri

166+includeSubschemas info (SchemaWithURI schema mURI) =

167+ SchemaWithURI schema mURI

189168 : (includeSubschemas info =<< subSchemas)

190169 where

191170 subSchemas :: [SchemaWithURI schema]

192171 subSchemas =

193− (\a -> SchemaWithURI a (updateResolutionScope mUri (_fiId info schema)))

194− <$> uncurry (<>) (_fiEmbedded info schema)

172+ let newScope = updateResolutionScope (BaseURI mURI) (_fiId info schema)

173+ updateScope s = SchemaWithURI s (_unBaseURI newScope)

174+ in updateScope <$> uncurry (<>) (_fiEmbedded info schema)

src/JSONSchema/Validator/Draft4.hs+13−12

@@ -1,4 +1,7 @@

11-- | Turn the validation functions into actual 'Validator's.

2+--

3+-- This is frankly a lot of busywork. It can perhaps be moved into the

4+-- validator modules themselves once we're sure this is the right design.

25

36module JSONSchema.Validator.Draft4

47 ( module JSONSchema.Validator.Draft4

@@ -9,16 +12,14 @@ import Import

912

1013import qualified Data.HashMap.Strict as HM

1114import qualified Data.List.NonEmpty as NE

12−import Data.Maybe (catMaybes, maybe, maybeToList)

13−import Data.Text (Text)

1415

1516import JSONSchema.Validator.Draft4.Any as Export

1617import JSONSchema.Validator.Draft4.Array as Export

1718import JSONSchema.Validator.Draft4.Number as Export

1819import JSONSchema.Validator.Draft4.Object as Export

1920import JSONSchema.Validator.Draft4.String as Export

21+import JSONSchema.Validator.Reference (BaseURI(..), Scope(..))

2022import JSONSchema.Validator.Types (Validator(..))

21−import JSONSchema.Validator.Utils (fromJSONEither)

2223

2324-- | For internal use.

2425--

@@ -75,6 +76,8 @@ minItemsValidator = Validator noEmbedded (run minItemsVal)

7576uniqueItemsValidator :: Validator a (Maybe UniqueItems) UniqueItemsInvalid

7677uniqueItemsValidator = Validator noEmbedded (run uniqueItemsVal)

7778

79+-- TODO: Add tests to the language agnostic test suite to

80+-- make sure @"additionalItems"@ subschemas are embedded correctly.

7881itemsRelatedValidator

7982 :: (schema -> Value -> [err])

8083 -> Validator schema (ItemsRelated schema) (ItemsRelatedInvalid err)

@@ -159,9 +162,6 @@ instance FromJSON schema => FromJSON (Definitions schema) where

159162 parseJSON = withObject "Definitions" $ \o ->

160163 Definitions <$> o .: "definitions"

161164

162−-- TODO: Add tests to the language agnostic test suite to

163−-- make sure these schemas are embedded correctly

164−-- (and do so for @"additionalItems"@ as well).

165165definitionsEmbedded

166166 :: Validator

167167 schema

@@ -180,15 +180,16 @@ definitionsEmbedded =

180180

181181refValidator

182182 :: (FromJSON schema, ToJSON schema)

183− => VisitedSchemas

184− -> Maybe Text

185− -> (Maybe Text -> Maybe schema)

186− -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])

183+ => (Text -> Maybe schema)

184+ -> (BaseURI -> schema -> BaseURI)

185+ -> (VisitedSchemas -> Scope schema -> schema -> Value -> [err])

186+ -> VisitedSchemas

187+ -> Scope schema

187188 -> Validator a (Maybe Ref) (RefInvalid err)

188−refValidator visited scope getRef f =

189+refValidator getRef updateScope f visited scope =

189190 Validator

190191 noEmbedded

191− (run (refVal visited scope getRef f))

192+ (run (refVal getRef updateScope f visited scope))

192193

193194enumValidator :: Validator a (Maybe EnumValidator) EnumInvalid

194195enumValidator = Validator noEmbedded (run enumVal)

src/JSONSchema/Validator/Draft4/Any.hs+115−23

@@ -9,11 +9,14 @@ import qualified Data.Scientific as SCI

99import Data.Semigroup (Semigroup) -- for older GHCs

1010import Data.Set (Set)

1111import qualified Data.Set as S

12+import Data.Text.Encoding.Error (UnicodeException)

1213import qualified JSONPointer as JP

14+import Network.HTTP.Types.URI (urlDecode)

1315

1416import qualified JSONSchema.Validator.Utils as UT

15−import JSONSchema.Validator.Reference (URIBaseAndFragment,

16− resolveFragment,

17+import JSONSchema.Validator.Reference (BaseURI(..),

18+ Scope(..),

19+ URIAndFragment,

1720 resolveReference)

1821

1922--------------------------------------------------

@@ -39,42 +42,131 @@ data RefInvalid err

3942 -- Also note that ideally we would enforce in the type system that any

4043 -- failing references be dealt with before valididation. Then this could

4144 -- be removed entirely.

42− | RefPointerResolution Text

43− | RefLoop Text VisitedSchemas URIBaseAndFragment

45+ | RefPointerResolution JSONPointerError

46+ | RefLoop Text VisitedSchemas URIAndFragment

4447 | RefInvalid Text Value (NonEmpty err)

4548 -- ^ 'Text' is the URI and 'Value' is the linked schema.

4649 deriving (Eq, Show)

4750

4851newtype VisitedSchemas

49− = VisitedSchemas { _unVisited :: [URIBaseAndFragment] }

52+ = VisitedSchemas { _unVisited :: [URIAndFragment] }

5053 deriving (Eq, Show, Semigroup, Monoid)

5154

5255refVal

5356 :: forall err schema. (FromJSON schema, ToJSON schema)

54− => VisitedSchemas

55− -> Maybe Text

56− -> (Maybe Text -> Maybe schema)

57− -> (VisitedSchemas -> Maybe Text -> schema -> Value -> [err])

57+ => (Text -> Maybe schema)

58+ -- ^ Look up a schema.

59+ -> (BaseURI -> schema -> BaseURI)

60+ -- ^ Update scope (needed after moving deeper into nested schemas).

61+ -> (VisitedSchemas -> Scope schema -> schema -> Value -> [err])

62+ -- ^ Validate data.

63+ -> VisitedSchemas

64+ -> Scope schema

5865 -> Ref

5966 -> Value

6067 -> Maybe (RefInvalid err)

61−refVal visited scope getRef f (Ref reference) x

68+refVal getRef updateScope val visited scope (Ref reference) x

6269 | (mURI, mFragment) `elem` _unVisited visited =

6370 Just (RefLoop reference visited (mURI, mFragment))

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

71+ | otherwise = leftToMaybe $ do

72+

73+ -- Get the referenced document

74+

75+ (newScope, doc) <- first RefResolution

76+ $ getDocument getRef updateScope scope mURI reference

77+

78+ -- Get the correct subschema within that document.

79+

80+ res <- case mFragment of

81+ Nothing -> Right (newScope, doc)

82+ Just fragment -> first RefPointerResolution

83+ $ resolveFragment updateScope newScope fragment

84+ let (finalScope, schema) = res

85+

86+ -- Check if that schema is valid.

87+

88+ let newVisited = VisitedSchemas [(_documentURI newScope, mFragment)]

89+ <> visited

90+ failures = val newVisited finalScope schema x

91+ first (RefInvalid reference (toJSON schema))

92+ . maybeToLeft ()

93+ $ NE.nonEmpty failures

94+ where

95+ mURI :: Maybe Text

96+ mFragment :: Maybe Text

97+ (mURI, mFragment) = resolveReference (_currentBaseURI scope) reference

98+

99+getDocument

100+ :: forall schema. (Text -> Maybe schema)

101+ -> (BaseURI -> schema -> BaseURI)

102+ -> Scope schema

103+ -> Maybe Text

104+ -> Text

105+ -> Either Text (Scope schema, schema)

106+ -- ^ 'Left' is the URI of the document we failed to resolve.

107+getDocument getRef updateScope scope mURI reference =

108+ case mURI <* fst (resolveReference (BaseURI Nothing) reference) of

109+ Nothing -> Right topOfThisDoc

110+ Just uri ->

111+ case getRef uri of

112+ Nothing -> Left uri

113+ Just s -> Right ( Scope s mURI (updateScope (BaseURI mURI) s)

114+ , s

115+ )

116+ where

117+ topOfThisDoc :: (Scope schema, schema)

118+ topOfThisDoc =

119+ ( scope { _currentBaseURI =

120+ updateScope (BaseURI (_documentURI scope))

121+ (_topLevelDocument scope)

122+ }

123+ , _topLevelDocument scope

124+ )

125+

126+data JSONPointerError

127+ = URLDecodingError UnicodeException -- | Aspirationally internal.

128+ | FormatError JP.FormatError

129+ | ResolutionError JP.ResolutionError

130+ | SubschemaDecodingError Text -- | Aspirationally internal.

131+ deriving (Eq, Show)

132+

133+resolveFragment

134+ :: forall schema. (FromJSON schema, ToJSON schema)

135+ => (BaseURI -> schema -> BaseURI)

136+ -> Scope schema

137+ -> Text

138+ -> Either JSONPointerError (Scope schema, schema)

139+resolveFragment updateScope scope fragment = do

140+ urlDecoded <- first URLDecodingError

141+ . decodeUtf8'

142+ . urlDecode True

143+ . encodeUtf8

144+ $ fragment

145+ JP.Pointer tokens <- first FormatError (JP.unescape urlDecoded)

146+ let acc = (toJSON (_topLevelDocument scope), _currentBaseURI scope)

147+ (schemaVal, base) <- foldM go acc tokens

148+ schema <- first SubschemaDecodingError (fromJSONEither schemaVal)

149+ pure (scope { _currentBaseURI = base }, schema)

76150 where

77− (mURI, mFragment) = resolveReference scope reference

151+ -- We have to step through the document JSON Pointer token

152+ -- by JSON Pointer token so that we can update the scope

153+ -- based on each @"id"@ we encounter.

154+ --

155+ -- TODO: Do we need specialized code to skip @"id"@s such

156+ -- as property keys that aren't meant to change scope?

157+ -- Perhaps this should be added to the language agnostic

158+ -- test suite as well.

159+ go :: (Value, BaseURI)

160+ -> JP.Token

161+ -> Either JSONPointerError (Value, BaseURI)

162+ go (lastVal, uri) tok = do

163+ v <- first ResolutionError (JP.resolveToken tok lastVal)

164+ case v of

165+ Array _ -> pure (v, uri)

166+ _ -> do

167+ -- PERFORMANCE: Avoid deserializing subschemas.

168+ schema <- first SubschemaDecodingError (fromJSONEither v)

169+ pure (v, updateScope uri schema)

78170

79171--------------------------------------------------

80172-- * enum

src/JSONSchema/Validator/Draft4/Array.hs+1−1

@@ -67,7 +67,7 @@ instance FromJSON UniqueItems where

6767 parseJSON = withObject "UniqueItems" $ \o ->

6868 UniqueItems <$> o .: "uniqueItems"

6969

70−data UniqueItemsInvalid

70+newtype UniqueItemsInvalid

7171 = UniqueItemsInvalid (Vector Value)

7272 deriving (Eq, Show)

7373

src/JSONSchema/Validator/Draft4/Object.hs+1−1

@@ -145,7 +145,7 @@ data DependencyMemberInvalid err

145145 | PropertyDepInvalid (Set Text) (HashMap Text Value)

146146 deriving (Eq, Show)

147147

148−data DependenciesInvalid err

148+newtype DependenciesInvalid err

149149 = DependenciesInvalid (HashMap Text (DependencyMemberInvalid err))

150150 deriving (Eq, Show)

151151

src/JSONSchema/Validator/Draft4/Object/Properties.hs+1

@@ -12,6 +12,7 @@ import qualified Text.Regex.PCRE.Heavy as RE

1212

1313data PropertiesRelated schema = PropertiesRelated

1414 { _propProperties :: Maybe (HashMap Text schema)

15+ -- ^ 'Maybe' is used to distinguish whether the key is present or not.

1516 , _propPattern :: Maybe (HashMap Text schema)

1617 , _propAdditional :: Maybe (AdditionalProperties schema)

1718 } deriving (Eq, Show)

src/JSONSchema/Validator/Reference.hs+27−35

@@ -8,37 +8,29 @@ module JSONSchema.Validator.Reference where

88

99import Import

1010

11−import qualified Data.Text as T

12−import Data.Text.Encoding (decodeUtf8, encodeUtf8)

13−import qualified JSONPointer as JP

14−import Network.HTTP.Types.URI (urlDecode)

15−import System.FilePath ((</>), dropFileName)

11+import qualified Data.Text as T

12+import System.FilePath ((</>), dropFileName)

1613

17−-- | TODO: Replace these with actual URI data types.

18−type URIBase = Maybe Text

19−type URIBaseAndFragment = (Maybe Text, Maybe Text)

14+data Scope schema = Scope

15+ { _topLevelDocument :: schema

16+ , _documentURI :: Maybe Text

17+ , _currentBaseURI :: BaseURI

18+ } deriving (Eq, Show)

2019

21−updateResolutionScope :: URIBase -> Maybe Text -> URIBase

22−updateResolutionScope mScope idKeyword

23− | Just t <- idKeyword = fst . baseAndFragment $ resolveScopeAgainst mScope t

24− | otherwise = mScope

20+newtype BaseURI

21+ = BaseURI { _unBaseURI :: Maybe Text }

22+ deriving (Eq, Show)

2523

26−resolveReference :: URIBase -> Text -> URIBaseAndFragment

27−resolveReference mScope t = baseAndFragment $ resolveScopeAgainst mScope t

24+-- | TODO: no `type`s.

25+type URIAndFragment = (Maybe Text, Maybe Text)

2826

29−resolveFragment

30− :: (FromJSON schema, ToJSON schema)

31− => Maybe Text

32− -> schema

33− -> Maybe schema

34−resolveFragment Nothing schema = Just schema

35−resolveFragment (Just pointer) schema = do

36− let urlDecoded = decodeUtf8 . urlDecode True . encodeUtf8 $ pointer

37− p <- either (const Nothing) Just (JP.unescape urlDecoded)

38− x <- either (const Nothing) Just (JP.resolve p (toJSON schema))

39− case fromJSON x of

40− Error _ -> Nothing

41− Success schema' -> Just schema'

27+updateResolutionScope :: BaseURI -> Maybe Text -> BaseURI

28+updateResolutionScope base idKeyword

29+ | Just t <- idKeyword = BaseURI . fst . baseAndFragment $ resolveScopeAgainst base t

30+ | otherwise = base

31+

32+resolveReference :: BaseURI -> Text -> URIAndFragment

33+resolveReference base t = baseAndFragment (resolveScopeAgainst base t)

4234

4335--------------------------------------------------

4436-- * Helpers

@@ -47,10 +39,10 @@ resolveFragment (Just pointer) schema = do

4739isRemoteReference :: Text -> Bool

4840isRemoteReference = T.isInfixOf "://"

4941

50−baseAndFragment :: Text -> URIBaseAndFragment

42+baseAndFragment :: Text -> URIAndFragment

5143baseAndFragment = f . T.splitOn "#"

5244 where

53− f :: [Text] -> URIBaseAndFragment

45+ f :: [Text] -> URIAndFragment

5446 f [x] = (g x, Nothing)

5547 f [x,y] = (g x, g y)

5648 f _ = (Nothing, Nothing)

@@ -58,9 +50,9 @@ baseAndFragment = f . T.splitOn "#"

5850 g "" = Nothing

5951 g x = Just x

6052

61−resolveScopeAgainst :: Maybe Text -> Text -> Text

62−resolveScopeAgainst Nothing t = t

63−resolveScopeAgainst (Just scope) t

53+resolveScopeAgainst :: BaseURI -> Text -> Text

54+resolveScopeAgainst (BaseURI Nothing) t = t

55+resolveScopeAgainst (BaseURI (Just base)) t

6456 | isRemoteReference t = t

6557 | otherwise = smartAppend

6658 where

@@ -69,11 +61,11 @@ resolveScopeAgainst (Just scope) t

6961 -- to cut it off before appending.

7062 smartAppend :: Text

7163 smartAppend =

72− case baseAndFragment scope of

73− (Just base,_) ->

64+ case baseAndFragment base of

65+ (Just uri,_) ->

7466 case T.unpack t of

7567 -- We want "/foo" and "#/bar" to combine into

7668 -- "/foo#/bar" not "/foo/#/bar".

7769 '#':_ -> base <> t

78− _ -> T.pack (dropFileName (T.unpack base) </> T.unpack t)

70+ _ -> T.pack (dropFileName (T.unpack uri) </> T.unpack t)

7971 _ -> t

src/JSONSchema/Validator/Utils.hs−10

@@ -123,13 +123,3 @@ instance Ord OrdValue where

123123

124124 (OrdValue (Object x)) `compare` (OrdValue (Object y)) =

125125 HM.toList (OrdValue <$> x) `compare` HM.toList (OrdValue <$> y)

126−

127−--------------------------------------------------

128−-- * other

129−--------------------------------------------------

130−

131−fromJSONEither :: FromJSON a => Value -> Either Text a

132−fromJSONEither a =

133− case fromJSON a of

134− Error e -> Left (T.pack e)

135− Success b -> Right b

test/Local.hs+3−4

@@ -10,8 +10,6 @@ import Test.Hspec

1010import Test.QuickCheck (property)

1111

1212import qualified JSONSchema.Draft4 as D4

13−import JSONSchema.Fetch (ReferencedSchemas(..),

14− URISchemaMap(..))

1513import qualified JSONSchema.Types as JT

1614import qualified Local.Failure

1715import qualified Local.Validation

@@ -84,8 +82,9 @@ main = do

8482 Left e -> panic ("Local.validateExample error: " <> show e)

8583 Right schemaMap -> do

8684 let failures = AlternateSchema.validate

87− (ReferencedSchemas s (_unURISchemaMap schemaMap))

88− Nothing s (_scData sc)

85+ schemaMap

86+ (D4.SchemaWithURI s Nothing)

87+ (_scData sc)

8988 assertResult sc failures

9089

9190quickCheckTests :: Spec

test/Local/Failure.hs+3−3

@@ -31,7 +31,7 @@ itemsArray =

3131 ]

3232 where

3333 failures :: [ValidatorFailure]

34− failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData

34+ failures = Spec.specValidate mempty sw badData

3535

3636 schema :: Schema

3737 schema = emptySchema

@@ -61,7 +61,7 @@ itemsObject =

6161 ]

6262 where

6363 failures :: [ValidatorFailure]

64− failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData

64+ failures = Spec.specValidate mempty sw badData

6565

6666 schema :: Schema

6767 schema = emptySchema

@@ -89,7 +89,7 @@ loopRef =

8989 ]

9090 where

9191 failures :: [ValidatorFailure]

92− failures = Spec.specValidate (ReferencedSchemas schema mempty) sw badData

92+ failures = Spec.specValidate mempty sw badData

9393

9494 schema :: Schema

9595 schema = emptySchema

test/Local/Reference.hs+12−12

@@ -10,28 +10,28 @@ import JSONSchema.Validator.Reference

1010spec :: Spec

1111spec = do

1212 it "updateResolutionScope gives correct results" $ do

13− updateResolutionScope Nothing Nothing

14− `shouldBe` Nothing

13+ updateResolutionScope (BaseURI Nothing) Nothing

14+ `shouldBe` BaseURI Nothing

1515

16− updateResolutionScope Nothing (Just "#")

17− `shouldBe` Nothing

16+ updateResolutionScope (BaseURI Nothing) (Just "#")

17+ `shouldBe` BaseURI Nothing

1818

19− updateResolutionScope Nothing (Just "foo")

20− `shouldBe` Just "foo"

19+ updateResolutionScope (BaseURI Nothing) (Just "foo")

20+ `shouldBe` BaseURI (Just "foo")

2121

2222 -- TODO: Normalize after updateResolutionScope:

23− updateResolutionScope (Just "/foo") (Just "./bar")

24− `shouldBe` Just "/./bar"

23+ updateResolutionScope (BaseURI (Just "/foo")) (Just "./bar")

24+ `shouldBe` BaseURI (Just "/./bar")

2525

2626 it "resolveReference gives correct results" $ do

27− resolveReference (Just "/foo") "bar"

27+ resolveReference (BaseURI (Just "/foo")) "bar"

2828 `shouldBe` (Just "/bar", Nothing)

2929

30− resolveReference (Just "/foo/bar") "/baz"

30+ resolveReference (BaseURI (Just "/foo/bar")) "/baz"

3131 `shouldBe` (Just "/baz", Nothing)

3232

33− resolveReference Nothing "#/bar"

33+ resolveReference (BaseURI Nothing) "#/bar"

3434 `shouldBe` (Nothing, Just "/bar")

3535

36− resolveReference (Just "/foo") "#/bar"

36+ resolveReference (BaseURI (Just "/foo")) "#/bar"

3737 `shouldBe` (Just "/foo", Just "/bar")

test/Remote.hs+3−4

@@ -11,8 +11,6 @@ import Network.Wai.Handler.Warp (run)

1111import Test.Hspec

1212

1313import qualified JSONSchema.Draft4 as D4

14−import JSONSchema.Fetch (ReferencedSchemas(..),

15− URISchemaMap(..))

1614import qualified JSONSchema.Types as JT

1715import Shared

1816

@@ -48,8 +46,9 @@ main = withAsync serve $ \_ -> do

4846 Left e -> panic ("Remote.validateExample error: " <> show e)

4947 Right schemaMap -> do

5048 let failures = AlternateSchema.validate

51− (ReferencedSchemas s (_unURISchemaMap schemaMap))

52− Nothing s (_scData sc)

49+ schemaMap

50+ (D4.SchemaWithURI s Nothing)

51+ (_scData sc)

5352 assertResult sc failures

5453

5554serve :: IO ()

test/Shared.hs+3−2

@@ -42,11 +42,12 @@ isHTTPTest file = (file == "definitions.json")

4242 || (file == "ref.json")

4343 || (file == "refRemote.json")

4444

45−-- | We may never support the @"format"@ keywords, and

46−-- are currently failing the zeroTerminatedFloats test.

45+-- | We may never support the @"format"@ keywords

46+-- and are currently failing the others listed here.

4747skipOptional :: FilePath -> Bool

4848skipOptional file = (file == "optional/format.json")

4949 || (file == "optional/zeroTerminatedFloats.json")

50+ || (file == "optional/ecmascript-regex.json")

5051

5152data SchemaTest = SchemaTest

5253 { _stDescription :: Text