diff options
Diffstat (limited to 'ldp/http-link.scm')
-rw-r--r-- | ldp/http-link.scm | 71 |
1 files changed, 71 insertions, 0 deletions
diff --git a/ldp/http-link.scm b/ldp/http-link.scm new file mode 100644 index 0000000..b750df1 --- /dev/null +++ b/ldp/http-link.scm @@ -0,0 +1,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))) |