blob: b750df16317c0e25fb2a2d3a3d6d598e25edc0be (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
(define-module (ldp http-link)
#:use-module (ice-9 peg)
#:use-module (web uri))
(define-peg-string-patterns
"links <-- (link (COMMA / ! link))*
link <-- OPENANGLE uri CLOSEANGLE properties
uri <-- (! CLOSEANGLE .)*
properties <-- (SEMICOLON property)*
property <-- key EQUAL QUOTE value QUOTE
key <-- ([a-zA-Z0-9_]/'-')*
value <-- (! QUOTE ((ESCAPE '\\') / (ESCAPE '\"') / (! ESCAPE .)))*
OPENANGLE < '<'
CLOSEANGLE < '>'
COMMA < ' '* ',' ' '*
SEMICOLON < ' '* ';' ' '*
EQUAL < ' '* '=' ' '*
QUOTE < '\"'
ESCAPE < '\\'
")
(define (fix-key key)
(unless (and (list? key)
(eq? (car key) 'key))
(throw 'bad-request))
(cadr key))
(define (fix-value value)
(unless (and (list? value)
(eq? (car value) 'value))
(throw 'bad-request))
(cadr value))
(define (fix-property prop)
(unless (and (list? prop)
(eq? (car prop) 'property))
(throw 'bad-request))
(let ((key (fix-key (cadr prop)))
(value (fix-value (caddr prop))))
`(,key . ,value)))
(define (fix-properties props)
(if (eq? props 'properties)
'()
(map fix-property (cdr props))))
(define (fix-uri uri)
(unless (and (list? uri)
(eq? (car uri) 'uri)
(string? (cadr uri))
(string->uri (cadr uri)))
(throw 'bad-request))
(string->uri (cadr uri)))
(define (fix-link link)
(unless (and (list? link)
(eq? (car link) 'link))
(throw 'bad-request))
(let ((uri (fix-uri (cadr link)))
(properties (fix-properties (caddr link))))
`(,uri . ,properties)))
(define (fix-links links)
(unless (and (list? links)
(eq? (car links) 'links))
(throw 'bad-request))
(map fix-link (cdr links)))
(define-public (string->links str)
(let ((tree (peg:tree (match-pattern links str))))
(fix-links tree)))
|
