diff options
Diffstat (limited to 'tests/http-link.scm')
| -rw-r--r-- | tests/http-link.scm | 178 |
1 files changed, 116 insertions, 62 deletions
diff --git a/tests/http-link.scm b/tests/http-link.scm index a16c353..062bb1a 100644 --- a/tests/http-link.scm +++ b/tests/http-link.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -14,12 +14,40 @@ ;; You should have received a copy of the GNU Affero General Public License ;; along with this program. If not, see <https://www.gnu.org/licenses/>. -(use-modules (webid-oidc http-link) - (webid-oidc testing) - (web http) - (web request) - (web response) - (web uri)) +(define-module (tests http-link) + #:use-module (webid-oidc http-link) + #:use-module (webid-oidc testing) + #:use-module (web http) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (oop goops)) + +(define-class <test-case> () + (encoded-form #:init-keyword #:encoded-form #:getter encoded-form) + (decoded-form #:init-keyword #:decoded-form #:getter decoded-form) + (one-way? #:init-keyword #:one-way? #:getter one-way? #:init-value #f)) + +(define-method (check (test <test-case>)) + (let ((decoded (parse-header 'link (encoded-form test))) + (encoded (and (not (one-way? test)) + (call-with-output-string + (lambda (port) + (write-header 'link (decoded-form test) port)))))) + (unless (and (equal? decoded (decoded-form test)) + (or (one-way? test) + (equal? encoded (format #f "Link: ~a\r\n" (encoded-form test))))) + (format (current-error-port) "Test case failed: +~s: + -> ~s + (expected ~s) +~s: + -> ~s + (expected ~s) +" + (encoded-form test) decoded (decoded-form test) + (decoded-form test) encoded (format #f "Link: ~a\r\n" (encoded-form test))) + (exit 1)))) (with-test-environment "http-link" @@ -27,63 +55,85 @@ (declare-link-header!) ;; Declare it twice to check that there’s no problem (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) - ;; This test is the first to fail if the Link header - ;; handler is not installed. - (exit 4)) - (unless (equal? four expected-four) - (exit 5)) - (unless (equal? five expected-five) - (exit 6)) - (unless (equal? six expected-six) - (exit 7))))) + (let ((cases + ;; These test cases are copied from rfc8288 + (list + (make <test-case> + #:encoded-form + "<http://example.com/TheBook/chapter2>; rel=\"previous\"; title=\"previous chapter\"" + #:decoded-form + (list + (make <link> + #:target-iri "http://example.com/TheBook/chapter2" + #:relation-type "previous" + #:title "previous chapter"))) + (make <test-case> + #:encoded-form + "</>; rel=\"http://example.net/foo\"" + #:decoded-form + (list + (make <link> + #:target-iri "/" + #:relation-type "http://example.net/foo"))) + (make <test-case> + #:encoded-form + "</terms>; rel=\"copyright\"; anchor=\"#foo\"" + #:decoded-form + (list + (make <link> + #:target-iri "/terms" + #:relation-type "copyright" + #:anchor "#foo"))) + (make <test-case> + #:encoded-form + "</TheBook/chapter2>; rel=\"previous\"; title*=UTF-8'de'letztes%20Kapitel, </TheBook/chapter4>; rel=\"next\"; title*=UTF-8'de'n%c3%a4chstes%20Kapitel" + #:decoded-form + (list + (make <link> + #:target-iri "/TheBook/chapter2" + #:relation-type "previous" + #:title* "UTF-8'de'letztes%20Kapitel") + (make <link> + #:target-iri "/TheBook/chapter4" + #:relation-type "next" + #:title* "UTF-8'de'n%c3%a4chstes%20Kapitel"))) + ;; These tests are mine, they check for more edge cases + (make <test-case> + #:encoded-form + "<https://example.com>; rel=\"b\"" + #:decoded-form + (list + (make <link> + #:target-iri "https://example.com" + #:relation-type "b"))) + (make <test-case> + #:encoded-form + "<https://example.com>; rel=\"\\\\b\\n\"" + #:decoded-form + (list + (make <link> + #:target-iri "https://example.com" + #:relation-type "\\b\n"))) + (make <test-case> + #:encoded-form + "<https://example.com>; rel=\"\\\\b\\n\"" + #:decoded-form + (list + (make <link> + #:target-iri "https://example.com" + #:relation-type "\\b\n")))))) + (for-each check cases)) + ;; Now, we check that the request / response API works (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"))) + (make <link> + #:target-iri first-link-uri + #:relation-type "type")) (second-link - `(,second-link-uri (rel . "type")))) + (make <link> + #:target-iri second-link-uri + #:relation-type "type"))) (let ((request (build-request (string->uri "https://example.com") #:headers @@ -93,6 +143,10 @@ (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")))) + (make <link> + #:target-iri "https://example.com/vocab#link" + #:relation-type "type") + (make <link> + #:target-iri "https://example.com/vocab#type" + #:relation-type "type"))) (exit 8))))))))) |