From 089ff9eea238de05159ed2eaee0bff93793c9a4c Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Thu, 10 Jun 2021 17:43:28 +0200 Subject: Add support for the HTTP Link header --- src/scm/webid-oidc/Makefile.am | 6 +- src/scm/webid-oidc/http-link.scm | 236 +++++++++++++++++++++++++++++++++++++++ tests/Makefile.am | 3 +- tests/http-link.scm | 78 +++++++++++++ 4 files changed, 320 insertions(+), 3 deletions(-) create mode 100644 src/scm/webid-oidc/http-link.scm create mode 100644 tests/http-link.scm 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 "") + (example-two "; ok") + (example-three "; a=b") + (example-four "; a=\"\\\\b\\n\"") + (example-five "; ok; a=b; a=\"\\\\b\\n\"") + (expected-zero "Link: <>\r\n") + (expected-one "Link: \r\n") + (expected-two "Link: ; ok\r\n") + (expected-three "Link: ; a=\"b\"\r\n") + (expected-four "Link: ; a=\"\\\\b\n\"\r\n") + (expected-five "Link: ; 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: <>, , ; ok, ; a=\"b\", ; a=\"\\\\b\n\", ; 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))))))))) -- cgit v1.2.3