create-term-definition.scm
1 | ;;;; Copyright (C) 2019, 2020 Julien Lepiller <julien@lepiller.eu> |
2 | ;;;; |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public |
5 | ;;;; License as published by the Free Software Foundation; either |
6 | ;;;; version 3 of the License, or (at your option) any later version. |
7 | ;;;; |
8 | ;;;; This library is distributed in the hope that it will be useful, |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | ;;;; Lesser General Public License for more details. |
12 | ;;;; |
13 | ;;;; You should have received a copy of the GNU Lesser General Public |
14 | ;;;; License along with this library; if not, write to the Free Software |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
16 | ;;;; |
17 | |
18 | (define-module (jsonld create-term-definition) |
19 | #:use-module (jsonld context) |
20 | #:use-module (jsonld context-processing) |
21 | #:use-module (jsonld iri-expansion) |
22 | #:use-module (jsonld iri) |
23 | #:use-module (jsonld json) |
24 | #:use-module (jsonld options) |
25 | #:use-module (json) |
26 | #:use-module (web uri) |
27 | #:use-module (rnrs bytevectors) |
28 | #:use-module (ice-9 match) |
29 | #:use-module (srfi srfi-9) |
30 | #:export (create-term-definition)) |
31 | |
32 | (define* (create-term-definition active-context local-context term defined |
33 | #:key (base-url #f) (protected? #f) |
34 | (override-protected? #f) |
35 | (remote-contexts '()) |
36 | (validate-scoped-context? #t) |
37 | (options (new-jsonld-options))) |
38 | "Create a term definition. This is an implementation of the create term |
39 | definition algorithm defined in the JsonLD API specification." |
40 | (match (assoc-ref defined term) |
41 | ;; 1 |
42 | ('true #t) |
43 | ('false (throw 'cyclic-iri-mapping)) |
44 | (_ |
45 | (begin |
46 | ;; 2 |
47 | (when (equal? term "") |
48 | (throw 'invalid-term-definition)) |
49 | ;; 2: This indicates that the term definition is now being created but |
50 | ;; is not yet complete. |
51 | (set! defined (alist-set defined term 'false)) |
52 | ;; 3 |
53 | (let ((value (assoc-ref local-context term))) |
54 | ;; 4 |
55 | (when (and (equal? term "@type") |
56 | (processing-mode-1.0? (jsonld-options-processing-mode options))) |
57 | (throw 'keyword-redefinition)) |
58 | ;; 4 |
59 | (if (equal? term "@type") |
60 | (unless (and (json-object? value) |
61 | (or (not (json-has-key? value "@container")) |
62 | (equal? (assoc-ref value "@container") "@set")) |
63 | (not (null? value)) |
64 | (null? (filter |
65 | (lambda (kp) |
66 | (not (member (car kp) '("@container" "@protected")))) |
67 | value))) |
68 | (throw 'keyword-redefinition)) |
69 | ;; 5 |
70 | (if (json-keyword? term) |
71 | (throw 'keyword-redefinition))) |
72 | ;; 5 TODO: generate a warning if it's a keyword-form but not @type |
73 | (unless (and (keyword-form? term) (not (equal? term "@type"))) |
74 | ;; 6 |
75 | (let ((previous-definition (term-definition-ref active-context term)) |
76 | (simple-term? #t) |
77 | ;; 10 |
78 | (definition (new-term-definition #:protected? protected?))) |
79 | (cond |
80 | ;; 7 |
81 | ((equal? value #nil) |
82 | (set! value `(("@id" . #nil)))) |
83 | ;; 8 |
84 | ((string? value) |
85 | (set! value `(("@id" . ,value)))) |
86 | ;; 9 |
87 | ((json-object? value) (set! simple-term? #f)) |
88 | (else (throw 'invalid-term-definition))) |
89 | ;; 11 |
90 | (when (json-has-key? value "@protected") |
91 | (when (processing-mode-1.0? (jsonld-options-processing-mode options)) |
92 | (throw 'invalid-term-definition)) |
93 | (set! definition (update-term-definition |
94 | definition |
95 | #:protected? (assoc-ref value "@protected"))) |
96 | (unless (member (assoc-ref value "@protected") '(#t #f)) |
97 | (throw 'invalid-@protected-value))) |
98 | ;; 12: if value contains the key @type |
99 | (when (json-has-key? value "@type") |
100 | ;; 12.1 |
101 | (let ((type (assoc-ref value "@type"))) |
102 | (unless (string? type) |
103 | (throw 'invalid-type-mapping)) |
104 | ;; 12.2 |
105 | (let ((result (iri-expansion active-context type |
106 | #:vocab? #t |
107 | #:local-context local-context |
108 | #:defined defined |
109 | #:options options))) |
110 | (set! active-context (assoc-ref result "active-context")) |
111 | (set! defined (assoc-ref result "defined")) |
112 | (set! type (assoc-ref result "iri"))) |
113 | ;; 12.3 |
114 | (when (and (member type '("@json" "@none")) |
115 | (processing-mode-1.0? (jsonld-options-processing-mode options))) |
116 | (throw 'invalid-type-mapping)) |
117 | ;; 12.4 |
118 | (unless (or (member type '("@id" "@vocab" "@json" "@none")) |
119 | (absolute-iri? type)) |
120 | (throw 'invalid-type-mapping value type)) |
121 | ;; 12.5 |
122 | (set! definition (update-term-definition definition #:type type)))) |
123 | |
124 | ;; 13: if value contains the key @reverse |
125 | (if (json-has-key? value "@reverse") |
126 | (begin |
127 | ;; 13.1 |
128 | (when (or (json-has-key? value "@id") (json-has-key? value "@nest")) |
129 | (throw 'invalid-reverse-property)) |
130 | ;; 13.2 |
131 | (unless (string? (assoc-ref value "@reverse")) |
132 | (throw 'invalid-iri-mapping)) |
133 | ;; 13.3 |
134 | (if (and (keyword-form? (assoc-ref value "@reverse")) |
135 | (not (json-keyword? (assoc-ref value "@reverse")))) |
136 | #t;; TODO: generate a warning before returning |
137 | (begin |
138 | ;; 13.4 |
139 | (let* ((result (iri-expansion active-context |
140 | (assoc-ref value "@reverse") |
141 | #:vocab? #t |
142 | #:local-context local-context |
143 | #:defined defined |
144 | #:options options)) |
145 | (iri (assoc-ref result "iri"))) |
146 | (unless (or (absolute-iri? iri) (blank-node? iri)) |
147 | (throw 'invalid-iri-mapping)) |
148 | (set! active-context (assoc-ref result "active-context")) |
149 | (set! defined (assoc-ref result "defined")) |
150 | ;; 13.5 |
151 | (when (json-has-key? value "@container") |
152 | (let ((container (assoc-ref value "@container"))) |
153 | (unless (member container '("@set" "@index" #nil)) |
154 | (throw 'invalid-reverse-property)) |
155 | (set! definition (update-term-definition definition |
156 | #:container container)))) |
157 | ;; 13.4 (cont.) and 13.6 |
158 | (set! definition (update-term-definition definition |
159 | #:iri iri #:reverse? #t)) |
160 | ;; 13.7: we return |
161 | (set! active-context (update-active-context |
162 | active-context |
163 | #:definitions |
164 | (alist-set |
165 | (active-context-definitions |
166 | active-context) |
167 | term definition))) |
168 | (set! defined (alist-set defined term 'true)))))) |
169 | ;; (not 13): otherwise, we continue |
170 | (begin |
171 | (let ((return? #f)) |
172 | (cond |
173 | ;; 14 |
174 | ((and (json-has-key? value "@id") |
175 | (not (equal? (assoc-ref value "@id") term))) |
176 | ;; 14.1 |
177 | (if (equal? (assoc-ref value "@id") #nil) |
178 | (set! definition (update-term-definition definition |
179 | #:iri #nil)) |
180 | ;; 14.2 |
181 | (begin |
182 | ;; 14.2.1 |
183 | (unless (string? (assoc-ref value "@id")) |
184 | (throw 'invalid-iri-mapping)) |
185 | ;; 14.2.2 |
186 | (if (and (not (json-keyword? (assoc-ref value "@id"))) |
187 | (keyword-form? (assoc-ref value "@id"))) |
188 | (set! return? #t);; return, should generate a warning |
189 | ;; 14.2.3 |
190 | (let* ((result (iri-expansion |
191 | active-context |
192 | (assoc-ref value "@id") |
193 | #:vocab? #t |
194 | #:local-context local-context |
195 | #:defined defined |
196 | #:options options)) |
197 | (iri (assoc-ref result "iri"))) |
198 | (set! active-context (assoc-ref result "active-context")) |
199 | (set! defined (assoc-ref result "defined")) |
200 | (set! definition (update-term-definition definition |
201 | #:iri iri)) |
202 | (unless (or (json-keyword? iri) (absolute-iri? iri) |
203 | (blank-node? iri)) |
204 | (throw 'invalid-iri-mapping)) |
205 | (when (equal? iri "@context") |
206 | (throw 'invalid-keyword-alias)) |
207 | ;; 14.2.4 |
208 | (if (or |
209 | (and |
210 | (> (string-length term) 1) |
211 | (string-index (substring term 1 (- (string-length term) 1)) #\:)) |
212 | (string-index term #\/)) |
213 | (begin |
214 | ;; 14.2.4.1 |
215 | (set! defined (alist-set defined term 'true)) |
216 | ;; 14.2.4.2 |
217 | (let ((result (iri-expansion |
218 | active-context |
219 | term |
220 | #:local-context local-context |
221 | #:defined defined |
222 | #:vocab? #t |
223 | #:options options))) |
224 | (set! active-context (assoc-ref result "active-context")) |
225 | (set! defined (assoc-ref result "defined")) |
226 | (unless (equal? |
227 | (assoc-ref result "iri") |
228 | iri) |
229 | (throw 'invalid-iri-mapping |
230 | term |
231 | iri |
232 | (assoc-ref result "iri"))))) |
233 | (when (and simple-term? |
234 | (or (blank-node? iri) |
235 | (gen-delim? (substring iri (- (string-length iri) 1))))) |
236 | (set! definition (update-term-definition |
237 | definition |
238 | #:prefix? #t))))))))) |
239 | ;; 15 |
240 | ((and (> (string-length term) 1) |
241 | (string-index (substring term 1) #\:)) |
242 | (let ((prefix (car (string-split term #\:))) |
243 | (suffix (apply string-append (cdr (string-split term #\:))))) |
244 | ;; 15.1 |
245 | (when (json-has-key? local-context prefix) |
246 | (let ((result (create-term-definition |
247 | active-context local-context prefix defined))) |
248 | (set! defined (assoc-ref result "defined")) |
249 | (set! active-context (assoc-ref result "active-context")))) |
250 | (if (term-definition-ref active-context prefix) |
251 | ;; 15.2 |
252 | (set! definition (update-term-definition definition |
253 | #:iri (string-append |
254 | (term-definition-iri |
255 | (term-definition-ref active-context prefix)) |
256 | suffix))) |
257 | ;; 15.3 |
258 | (set! definition (update-term-definition definition |
259 | #:iri term))))) |
260 | ;; 16 |
261 | ((string-index term #\/) |
262 | (let* ((result (iri-expansion active-context term |
263 | #:vocab? #t |
264 | #:options options)) |
265 | (iri (assoc-ref result "iri"))) |
266 | (set! active-context (assoc-ref result "active-context")) |
267 | (set! defined (assoc-ref result "defined")) |
268 | (unless (absolute-iri? iri) |
269 | (throw 'invalid-iri-mapping)) |
270 | (set! definition (update-term-definition definition |
271 | #:iri iri)))) |
272 | ;; 17 |
273 | ((equal? term "@type") |
274 | (set! definition (update-term-definition |
275 | definition #:iri "@type"))) |
276 | ;; 18 |
277 | ((active-context-vocab active-context) |
278 | (set! definition (update-term-definition definition |
279 | #:iri (string-append |
280 | (active-context-vocab active-context) |
281 | term)))) |
282 | (else (throw 'invalid-iri-mapping))) |
283 | (unless return? |
284 | ;; 19 |
285 | (when (json-has-key? value "@container") |
286 | ;; 19.1 |
287 | (let ((container (assoc-ref value "@container"))) |
288 | (match container |
289 | ((? string? container) |
290 | (unless (member container |
291 | '("@graph" "@id" "@index" "@language" |
292 | "@list" "@set" "@type")) |
293 | (throw 'invalid-container-mapping)) |
294 | ;; 19.2 |
295 | (when (and (member container '("@graph" "@id" "@type")) |
296 | (processing-mode-1.0? |
297 | (jsonld-options-processing-mode options))) |
298 | (throw 'invalid-container-mapping))) |
299 | ((? json-array? container) |
300 | (let ((container (array->list container))) |
301 | (unless (or |
302 | (and |
303 | (= (length container) 1) |
304 | (member (car container) |
305 | '("@graph" "@id" "@index" "@language" |
306 | "@list" "@set" "@type"))) |
307 | (and |
308 | (member "@graph" container) |
309 | (or |
310 | (member "@id" container) |
311 | (member "@index" container)) |
312 | (null? |
313 | (filter |
314 | (lambda (p) |
315 | (not (member p |
316 | '("@id" "@index" "@graph" |
317 | "@set")))) |
318 | container))) |
319 | (and |
320 | (member "@set" container) |
321 | (or |
322 | (member "@index" container) |
323 | (member "@graph" container) |
324 | (member "@id" container) |
325 | (member "@type" container) |
326 | (member "@language" container)))) |
327 | (throw 'invalid-container-mapping)) |
328 | ;; 19.2 |
329 | (when (processing-mode-1.0? |
330 | (jsonld-options-processing-mode options)) |
331 | (throw 'invalid-container-mapping)))) |
332 | (_ (throw 'invalid-container-mapping))) |
333 | ;; 19.3 |
334 | (set! container (if (json-array? container) |
335 | container |
336 | `#(,container))) |
337 | (set! definition (update-term-definition definition |
338 | #:container container)) |
339 | ;; 19.4 |
340 | (when (member "@type" (array->list container)) |
341 | ;; 19.4.1 |
342 | (unless (term-definition-type definition) |
343 | (set! definition |
344 | (update-term-definition definition |
345 | #:type "@id"))) |
346 | ;; 19.4.2 |
347 | (unless (member (term-definition-type definition) |
348 | '("@id" "@vocab")) |
349 | (throw 'invalid-type-mapping))))) |
350 | ;; 20 |
351 | (when (json-has-key? value "@index") |
352 | ;; 20.1 |
353 | (when (or (processing-mode-1.0? |
354 | (jsonld-options-processing-mode options)) |
355 | (not (member |
356 | "@index" |
357 | (array->list |
358 | (or (term-definition-container |
359 | definition) |
360 | #()))))) |
361 | (throw 'invalid-term-definition)) |
362 | ;; 20.2 |
363 | (let* ((index (assoc-ref value "@index")) |
364 | (extended-index |
365 | (assoc-ref |
366 | (iri-expansion active-context index |
367 | #:vocab? #t |
368 | #:options options) |
369 | "iri"))) |
370 | (unless (and (string? extended-index) |
371 | (absolute-iri? extended-index)) |
372 | (throw 'invalid-term-definition)) |
373 | ;; 20.3 |
374 | (set! definition |
375 | (update-term-definition definition #:index index)))) |
376 | ;; 21 |
377 | (when (json-has-key? value "@context") |
378 | ;; 21.1 |
379 | (when (processing-mode-1.0? (jsonld-options-processing-mode options)) |
380 | (throw 'invalid-term-definition)) |
381 | ;; 21.2 |
382 | (let ((context (assoc-ref value "@context"))) |
383 | ;; the result is discarded, it will be reprocessed if |
384 | ;; used. It is only here to detect errors |
385 | (catch #t |
386 | (lambda () |
387 | (context-processing active-context context base-url |
388 | #:override-protected? #t |
389 | #:remote-contexts remote-contexts |
390 | #:validate-scoped-context? #f |
391 | #:options options)) |
392 | (lambda (key . value) |
393 | (apply throw 'invalid-scoped-context key value))) |
394 | (set! definition |
395 | (update-term-definition definition #:context context |
396 | #:base-url base-url)))) |
397 | ;; 22 |
398 | (when (and (json-has-key? value "@language") |
399 | (not (json-has-key? value "@type"))) |
400 | ;; 22.1 |
401 | (let ((language (assoc-ref value "@language"))) |
402 | (unless (or (string? language) (equal? language #nil)) |
403 | (throw 'invalid-language-mapping)) |
404 | ;; a warning should be thrown if not bcp-47 compliant |
405 | ;; 22.2 |
406 | (when (string? language) |
407 | (set! language (string-downcase language))) |
408 | (set! definition (update-term-definition definition |
409 | #:language language)))) |
410 | ;; 23 |
411 | (when (and (json-has-key? value "@direction") |
412 | (not (json-has-key? value "@type"))) |
413 | ;; 23.1 |
414 | (let ((direction (assoc-ref value "@direction"))) |
415 | (unless (member direction '("ltr" "rtl" #nil)) |
416 | (throw 'invalid-base-direction)) |
417 | ;; 23.2 |
418 | (set! definition (update-term-definition definition |
419 | #:direction direction)))) |
420 | ;; 24 |
421 | (when (json-has-key? value "@nest") |
422 | ;; 24.1 |
423 | (when (processing-mode-1.0? (jsonld-options-processing-mode options)) |
424 | (throw 'invalid-term-definition)) |
425 | ;; 24.2 |
426 | (let ((nest (assoc-ref value "@nest"))) |
427 | (when (or (not (string? nest)) |
428 | (and (json-keyword? nest) |
429 | (not (equal? nest "@nest")))) |
430 | (throw 'invalid-@nest-value)) |
431 | (set! definition |
432 | (update-term-definition definition #:nest nest)))) |
433 | ;; 25 |
434 | (when (json-has-key? value "@prefix") |
435 | ;; 25.1 |
436 | (when (or (processing-mode-1.0? |
437 | (jsonld-options-processing-mode options)) |
438 | (string-index term #\:) |
439 | (string-index term #\/)) |
440 | (throw 'invalid-term-definition)) |
441 | ;; 25.2 |
442 | (let ((prefix? (assoc-ref value "@prefix"))) |
443 | (unless (member prefix? '(#t #f)) |
444 | (throw 'invalid-@prefix-value)) |
445 | (set! definition |
446 | (update-term-definition definition #:prefix? prefix?)) |
447 | ;; 25.3 |
448 | (when (and prefix? |
449 | (json-keyword? (term-definition-iri definition))) |
450 | (throw 'invalid-term-definition)))) |
451 | ;; 26 |
452 | (unless (null? (filter |
453 | (lambda (kp) |
454 | (not (member (car kp) |
455 | '("@id" "@reverse" "@container" |
456 | "@context" "@direction" |
457 | "@index" "@language" |
458 | "@nest" "@prefix" |
459 | "@protected" "@type")))) |
460 | value)) |
461 | (throw 'invalid-term-definition)) |
462 | ;; 27 |
463 | (unless (or override-protected? (not previous-definition) |
464 | (not (term-definition-protected? previous-definition))) |
465 | ;; 27.1 |
466 | (unless (term-definition-equal? |
467 | (update-term-definition definition #:protected? #t) |
468 | previous-definition) |
469 | (throw 'protected-term-redefinition)) |
470 | ;; 27.2 |
471 | (set! definition previous-definition)) |
472 | ;; 28 |
473 | (set! defined (alist-set defined term 'true)) |
474 | (set! active-context |
475 | (update-active-context |
476 | active-context |
477 | #:definitions |
478 | (alist-set (active-context-definitions active-context) |
479 | term definition))))))))))))) |
480 | ;; return an alist of potentially modified objects: defined and active-context. |
481 | `(("defined" . ,defined) ("active-context" . ,active-context))) |
482 |