Add support for the HTTP Link header

4 files changed, 320 insertions, 3 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 11f1b8b..732fd3d 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -25,7 +25,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/reverse-proxy.scm \
   %reldir%/client.scm \
   %reldir%/example-app.scm \
-  %reldir%/rdf-index.scm
+  %reldir%/rdf-index.scm \
+  %reldir%/http-link.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -54,7 +55,8 @@ webidoidcgo_DATA += \
   %reldir%/reverse-proxy.go \
   %reldir%/client.go \
   %reldir%/example-app.go \
-  %reldir%/rdf-index.go
+  %reldir%/rdf-index.go \
+  %reldir%/http-link.go
 
 EXTRA_DIST += %reldir%/ChangeLog
 
diff --git a/src/scm/webid-oidc/http-link.scm b/src/scm/webid-oidc/http-link.scm
new file mode 100644
index 0000000..ef09510
--- /dev/null
+++ b/src/scm/webid-oidc/http-link.scm
@@ -0,0 +1,236 @@
+(define-module (webid-oidc http-link)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 peg)
+  #:use-module (web uri)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web http)
+  #:export
+  (
+
+   declare-link-header!
+   request-links
+   response-links
+
+   ))
+
+(define-peg-string-patterns
+  "links <-- link (comma link)*
+link <-- uri-reference (semicolon parameter)*
+comma < whitespace* ','
+uri-reference <-- open-angle (uri-character)* close-angle
+semicolon < whitespace* ';'
+parameter <-- kv-parameter / single-parameter
+single-parameter <- key
+kv-parameter <-- key equals value
+key <-- string
+equals < whitespace* '='
+value <-- string
+whitespace < ' ' / '\\t' / '\\n' / '\\r'
+open-angle < whitespace* '<'
+uri-character <-- ! close-angle .
+close-angle < whitespace* '>'
+string <-- (double-quote quoted-string double-quote) / (whitespace* unquoted-string)
+double-quote < whitespace* '\"'
+quoted-string <-- (plain-character / escape-tab / escape-newline / escape-return / escape-sequence)*
+plain-character <-- (! ('\\' / '\"') .)
+unquoted-string <-- (! (',' / ';' / '=') plain-character)*
+escape-sequence <-- escape .
+escape < '\\'
+escape-tab <-- '\\' 't'
+escape-newline <-- '\\' 'n'
+escape-return <-- '\\' 'r'
+")
+
+(define (fix-escape-return datum)
+  '(#\return))
+
+(define (fix-escape-newline datum)
+  '(#\newline))
+
+(define (fix-escape-tab datum)
+  '(#\tab))
+
+(define (fix-escape-sequence datum)
+  (string->list (car datum)))
+
+(define (fix-unquoted-string datum)
+  (list->string (apply append (map fix datum))))
+
+(define (fix-plain-character datum)
+  (string->list (car datum)))
+
+(define (fix-quoted-string datum)
+  (list->string (apply append (map fix datum))))
+
+(define (fix-string datum)
+  (fix (car datum)))
+
+(define (fix-uri-character datum)
+  (string->list (car datum)))
+
+(define (fix-value datum)
+  (fix (car datum)))
+
+(define (fix-key datum)
+  (string->symbol (string-downcase (fix (car datum)))))
+
+(define (fix-kv-parameter datum)
+  (let ((key (fix (car datum)))
+        (value (fix (cadr datum))))
+    (cons key value)))
+
+(define (fix-single-parameter datum)
+  (fix (car datum)))
+
+(define (fix-parameter datum)
+  (fix (car datum)))
+
+(define (fix-uri-reference datum)
+  (string->uri-reference (list->string (apply append (map fix datum)))))
+
+(define (fix-link datum)
+  (define (fix-parameters parameters)
+    ;; Sometimes guile wraps it into another layer of lists (when there
+    ;; are at least 2 parameters)
+    (cond
+     ((and (not (null? parameters))
+           (null? (cdr parameters))
+           (list? (car parameters))
+           (not (null? (car parameters)))
+           (list? (caar parameters)))
+      (fix-parameters (car parameters)))
+     ((null? parameters)
+      '())
+     (else
+      (let ((first (fix (car parameters)))
+            (rest (fix-parameters (cdr parameters))))
+        (cons first rest)))))
+  (let ((parameters (fix-parameters (cdr datum)))
+        (uri (fix (car datum))))
+    (cons uri parameters)))
+
+(define (fix-links datum)
+  ;; Same
+  (if (null? datum)
+      '()
+      (let ((first (car datum))
+            (rest (cdr datum)))
+        (if (and (list? first)
+                 (not (null? first))
+                 (list? (car first))
+                 (null? rest))
+            (fix-links first)
+            (cons (fix first) (fix-links rest))))))
+
+(define (fix datum)
+  (if (list? datum)
+      (let ((key (car datum))
+            (value (cdr datum)))
+        ((case key
+          ((escape-return) fix-escape-return)
+          ((escape-newline) fix-escape-newline)
+          ((escape-tab) fix-escape-tab)
+          ((escape-sequence) fix-escape-sequence)
+          ((unquoted-string) fix-unquoted-string)
+          ((plain-character) fix-plain-character)
+          ((quoted-string) fix-quoted-string)
+          ((string) fix-string)
+          ((uri-character) fix-uri-character)
+          ((value) fix-value)
+          ((key) fix-key)
+          ((kv-parameter) fix-kv-parameter)
+          ((single-parameter) fix-single-parameter)
+          ((parameter) fix-parameter)
+          ((uri-reference) fix-uri-reference)
+          ((link) fix-link)
+          ((links) fix-links))
+         value))
+      (fix (list datum))))
+
+(define (parse str)
+  (let ((tree (peg:tree (match-pattern links str))))
+    (and tree (fix tree))))
+
+(define (validate links)
+  (define (validate-one-link link)
+    (define (validate-parameters params)
+      (define (validate-one-parameter parameter)
+        (or (symbol? parameter)
+            (and (pair? parameter)
+                 (symbol? (car parameter))
+                 (string? (cdr parameter)))))
+      (and (list? params)
+           (or (null? params)
+               (and (validate-one-parameter (car params))
+                    (validate-parameters (cdr params))))))
+    (and (list? link)
+         (uri-reference? (car link))
+         (validate-parameters (cdr link))))
+  (and (list? links)
+       (or (null? links)
+           (and (validate-one-link (car links))
+                (validate (cdr links))))))
+
+(define (write links port)
+  (define (replace-close-angle accu input)
+    (cond
+     ((null? input)
+      (list->string (reverse accu)))
+     ((eqv? (car input) #\>)
+      (replace-close-angle accu (cons* #\% #\3 #\E (cdr input))))
+     (else
+      (replace-close-angle (cons (car input) accu) (cdr input)))))
+  (define (escape accu input)
+    (cond
+     ((null? input)
+      (string-append "\"" (list->string (reverse accu)) "\""))
+     ((eqv? (car input) #\\)
+      (escape (cons* #\\ #\\ accu) (cdr input)))
+     ((eqv? (car input) #\")
+      (escape (cons* #\" #\\ accu) (cdr input)))
+     (else
+      (escape (cons (car input) accu) (cdr input)))))
+  (define (write-one-link link)
+    (define (write-parameters params)
+      (define (write-parameter param)
+        (if (symbol? param)
+            (string-append "; " (symbol->string param))
+            (format #f "; ~a=~a"
+                    (symbol->string (car param))
+                    (escape '() (string->list (cdr param))))))
+      (string-join (map write-parameter params) ""))
+    (string-append
+     "<"
+     (replace-close-angle '() (string->list (uri->string (car link))))
+     ">"
+     (write-parameters (cdr link))))
+  (display
+   (string-join (map write-one-link links) ", ")
+   port))
+
+(define (declare-link-header!)
+  (declare-header!
+   "Link"
+   parse
+   validate
+   write))
+
+(define (request-links request)
+  (apply append
+         (map
+          (lambda (header)
+            (if (eq? (car header) 'link)
+                (cdr header)
+                '()))
+          (request-headers request))))
+
+(define (response-links response)
+  (apply append
+         (map
+          (lambda (header)
+            (if (eq? (car header) 'link)
+                (cdr header)
+                '()))
+          (response-headers response))))
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 17aa6f4..4d7fda4 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -42,7 +42,8 @@ TESTS = %reldir%/load-library.scm \
   %reldir%/client-token.scm \
   %reldir%/client-manifest-not-modified.scm \
   %reldir%/server-content.scm \
-  %reldir%/server-path.scm
+  %reldir%/server-path.scm \
+  %reldir%/http-link.scm
 
 EXTRA_DIST += $(TESTS) %reldir%/ChangeLog
 
diff --git a/tests/http-link.scm b/tests/http-link.scm
new file mode 100644
index 0000000..b2e4aa3
--- /dev/null
+++ b/tests/http-link.scm
@@ -0,0 +1,78 @@
+(use-modules (webid-oidc http-link)
+             (webid-oidc testing)
+             (web http)
+             (web request)
+             (web response)
+             (web uri))
+
+(with-test-environment
+ "http-link"
+ (lambda ()
+   (declare-link-header!)
+   (let ((example-zero "<>")
+         (example-one "<h>")
+         (example-two "<https://two.example.com>; ok")
+         (example-three "<https://three.example.com>; a=b")
+         (example-four "<https://four.example.com>; a=\"\\\\b\\n\"")
+         (example-five "<https://five.example.com>; ok; a=b; a=\"\\\\b\\n\"")
+         (expected-zero "Link: <>\r\n")
+         (expected-one "Link: <h>\r\n")
+         (expected-two "Link: <https://two.example.com>; ok\r\n")
+         (expected-three "Link: <https://three.example.com>; a=\"b\"\r\n")
+         (expected-four "Link: <https://four.example.com>; a=\"\\\\b\n\"\r\n")
+         (expected-five "Link: <https://five.example.com>; ok; a=\"b\"; a=\"\\\\b\n\"\r\n"))
+     (let ((example-six
+            (string-join (list
+                          example-zero
+                          example-one
+                          example-two
+                          example-three
+                          example-four
+                          example-five)
+                         ", "))
+           (expected-six
+            "Link: <>, <h>, <https://two.example.com>; ok, <https://three.example.com>; a=\"b\", <https://four.example.com>; a=\"\\\\b\n\", <https://five.example.com>; ok; a=\"b\"; a=\"\\\\b\n\"\r\n"))
+       (define (test str)
+         (let ((parsed (parse-header 'link str)))
+           (call-with-output-string
+             (lambda (port)
+               (write-header 'link parsed port)))))
+       (let ((zero (test example-zero))
+             (one (test example-one))
+             (two (test example-two))
+             (three (test example-three))
+             (four (test example-four))
+             (five (test example-five))
+             (six (test example-six)))
+         (unless (equal? zero expected-zero)
+           (exit 1))
+         (unless (equal? one expected-one)
+           (exit 2))
+         (unless (equal? two expected-two)
+           (exit 3))
+         (unless (equal? three expected-three)
+           (exit 4))
+         (unless (equal? four expected-four)
+           (exit 5))
+         (unless (equal? five expected-five)
+           (exit 6))
+         (unless (equal? six expected-six)
+           (exit 7)))))
+   (let ((first-link-uri (string->uri "https://example.com/vocab#link"))
+         (second-link-uri (string->uri "https://example.com/vocab#type")))
+     (let ((first-link
+            `(,first-link-uri (rel . "type")))
+           (second-link
+            `(,second-link-uri (rel . "type"))))
+       (let ((request (build-request
+                       (string->uri "https://example.com")
+                       #:headers
+                       `((link . (,first-link))
+                         (link . (,second-link))))))
+         (let ((response (build-response #:headers `((link . ,(request-links request))))))
+           (let ((links (response-links response)))
+             (unless (equal? links
+                             (list
+                              (list (string->uri "https://example.com/vocab#link") (cons 'rel "type"))
+                              (list (string->uri "https://example.com/vocab#type") (cons 'rel "type"))))
+               (exit 8)))))))))