1
- module JsonSchema.Validation (Violation , validateAgainst ) where
1
+ module JsonSchema.Validation
2
+ ( JsonPath
3
+ , JsonPathSegment (..)
4
+ , SchemaPath
5
+ , SchemaPathSegment (..)
6
+ , Violation
7
+ , ViolationReason (..)
8
+ , renderJsonPath
9
+ , renderSchemaPath
10
+ , renderViolationReason
11
+ , validateAgainst
12
+ ) where
2
13
3
14
import Prelude
4
15
5
16
import Data.Argonaut.Core (Json )
6
17
import Data.Argonaut.Core as A
18
+ import Data.Array as Array
19
+ import Data.Foldable (foldMap )
20
+ import Data.Generic.Rep (class Generic )
7
21
import Data.Int as Int
22
+ import Data.List (List , (:))
23
+ import Data.List as List
8
24
import Data.Maybe (Maybe (..), maybe )
9
25
import Data.Set (Set )
10
26
import Data.Set as Set
11
- import JsonSchema (JsonSchema (..), JsonValueType (..), Keywords )
27
+ import Data.Show.Generic (genericShow )
28
+ import Data.String as String
29
+ import JsonSchema
30
+ ( JsonSchema (..)
31
+ , JsonValueType (..)
32
+ , Keywords
33
+ , renderJsonValueType
34
+ )
35
+ import JsonSchema as Schema
12
36
13
- type Violation = { description ∷ String , path ∷ String }
37
+ type JsonPath = List JsonPathSegment
38
+
39
+ renderJsonPath ∷ JsonPath → String
40
+ renderJsonPath = (" $" <> _) <<< foldMap f <<< List .reverse
41
+ where
42
+ f ∷ JsonPathSegment → String
43
+ f = case _ of
44
+ Property name →
45
+ " /" <> name
46
+
47
+ data JsonPathSegment = Property String
48
+
49
+ derive instance Eq JsonPathSegment
50
+ derive instance Generic JsonPathSegment _
51
+ derive instance Ord JsonPathSegment
52
+
53
+ instance Show JsonPathSegment where
54
+ show = genericShow
55
+
56
+ type SchemaPath = List SchemaPathSegment
57
+
58
+ renderSchemaPath ∷ SchemaPath → String
59
+ renderSchemaPath = (" #" <> _) <<< foldMap f <<< List .reverse
60
+ where
61
+ f ∷ SchemaPathSegment → String
62
+ f = case _ of
63
+ TypeKeyword →
64
+ " /type"
65
+
66
+ data SchemaPathSegment = TypeKeyword
67
+
68
+ derive instance Eq SchemaPathSegment
69
+ derive instance Generic SchemaPathSegment _
70
+ derive instance Ord SchemaPathSegment
71
+
72
+ instance Show SchemaPathSegment where
73
+ show = genericShow
74
+
75
+ type Violation =
76
+ { jsonPath ∷ JsonPath
77
+ , reason ∷ ViolationReason
78
+ , schemaPath ∷ SchemaPath
79
+ }
80
+
81
+ data ViolationReason
82
+ = AlwaysFailingSchema
83
+ | TypeMismatch
84
+ { actualJsonValueType ∷ JsonValueType
85
+ , allowedJsonValueTypes ∷ Set JsonValueType
86
+ }
87
+ | ValidAgainstNotSchema
88
+
89
+ derive instance Eq ViolationReason
90
+ derive instance Generic ViolationReason _
91
+ derive instance Ord ViolationReason
92
+
93
+ instance Show ViolationReason where
94
+ show = genericShow
95
+
96
+ renderViolationReason ∷ ViolationReason → String
97
+ renderViolationReason = case _ of
98
+ AlwaysFailingSchema →
99
+ " Schema always fails validation."
100
+ TypeMismatch { actualJsonValueType, allowedJsonValueTypes } →
101
+ " Invalid type. Expected "
102
+ <>
103
+ ( case Array .fromFoldable allowedJsonValueTypes of
104
+ [] →
105
+ " none"
106
+ [ allowedJsonValueType ] →
107
+ Schema .renderJsonValueType allowedJsonValueType
108
+ _ →
109
+ String .joinWith " or "
110
+ $ renderJsonValueType
111
+ <$> Array .fromFoldable allowedJsonValueTypes
112
+ )
113
+ <> " but got "
114
+ <> Schema .renderJsonValueType actualJsonValueType
115
+ <> " ."
116
+ ValidAgainstNotSchema →
117
+ " JSON is valid against schema from 'not'."
14
118
15
119
validateAgainst ∷ Json → JsonSchema → Set Violation
16
- validateAgainst json schema = case schema of
17
- BooleanSchema bool →
18
- if bool then Set .empty
19
- else Set .singleton { description: " invalid JSON value" , path: " ?" }
20
- ObjectSchema keywords →
21
- validateAgainstObjectSchema json keywords
120
+ validateAgainst = go mempty mempty
121
+ where
122
+ go ∷ SchemaPath → JsonPath → Json → JsonSchema → Set Violation
123
+ go schemaPath jsonPath json schema = case schema of
124
+ BooleanSchema bool →
125
+ if bool then Set .empty
126
+ else Set .singleton
127
+ { jsonPath, reason: AlwaysFailingSchema , schemaPath }
128
+
129
+ ObjectSchema keywords →
130
+ validateAgainstObjectSchema schemaPath jsonPath json keywords
22
131
23
132
validateAgainstObjectSchema
24
- ∷ Json → Keywords → Set Violation
25
- validateAgainstObjectSchema json keywords =
133
+ ∷ SchemaPath → JsonPath → Json → Keywords → Set Violation
134
+ validateAgainstObjectSchema schemaPath jsonPath json keywords =
26
135
notViolations <> typeKeywordViolations
27
136
where
137
+ notViolations ∷ Set Violation
28
138
notViolations = case keywords.not of
29
139
Just schema →
30
140
if Set .isEmpty $ validateAgainst json schema then Set .singleton
31
- { description: " JSON value matches schema when it should not."
32
- , path: " ?"
141
+ { jsonPath
142
+ , reason: ValidAgainstNotSchema
143
+ , schemaPath
33
144
}
34
145
else Set .empty
35
146
Nothing →
@@ -38,13 +149,19 @@ validateAgainstObjectSchema json keywords =
38
149
typeKeywordViolations ∷ Set Violation
39
150
typeKeywordViolations = maybe
40
151
Set .empty
41
- (validateTypeKeyword json)
152
+ (validateTypeKeyword schemaPath jsonPath json)
42
153
keywords.typeKeyword
43
154
44
- validateTypeKeyword ∷ Json → Set JsonValueType → Set Violation
45
- validateTypeKeyword json allowedJsonValueTypes =
155
+ validateTypeKeyword
156
+ ∷ SchemaPath → JsonPath → Json → Set JsonValueType → Set Violation
157
+ validateTypeKeyword schemaPath jsonPath json allowedJsonValueTypes =
46
158
if jsonValueType `Set.member` allowedJsonValueTypes then Set .empty
47
- else Set .singleton { description: " " , path: " ?" }
159
+ else Set .singleton
160
+ { jsonPath
161
+ , reason: TypeMismatch
162
+ { actualJsonValueType: jsonValueType, allowedJsonValueTypes }
163
+ , schemaPath: TypeKeyword : schemaPath
164
+ }
48
165
where
49
166
jsonValueType ∷ JsonValueType
50
167
jsonValueType = A .caseJson
0 commit comments