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)))