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