diff options
-rw-r--r-- | doc/disfluid.texi | 66 | ||||
-rw-r--r-- | po/disfluid.pot | 46 | ||||
-rw-r--r-- | po/fr.po | 60 | ||||
-rw-r--r-- | src/scm/webid-oidc/http-link.scm | 373 | ||||
-rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 4 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/delete.scm | 1 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/precondition.scm | 3 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/read.scm | 86 | ||||
-rw-r--r-- | src/scm/webid-oidc/server/update.scm | 1 | ||||
-rw-r--r-- | tests/crud.scm | 46 | ||||
-rw-r--r-- | tests/http-link.scm | 178 |
11 files changed, 683 insertions, 181 deletions
diff --git a/doc/disfluid.texi b/doc/disfluid.texi index 011f3f9..be32b85 100644 --- a/doc/disfluid.texi +++ b/doc/disfluid.texi @@ -71,6 +71,7 @@ A PDF version of this manual is available at * Client manifest:: * The Json Web Token:: * Caching on server side:: +* The HTTP Link header:: * Content negociation:: * Running an Identity Provider:: * Running a Resource Server:: @@ -1401,6 +1402,71 @@ This parameters sets the cache directory. By default, it is @emph{XDG_CACHE_HOME}. @end deffn +@node The HTTP Link header +@chapter The HTTP Link header +The HTTP Link header lets you attach metadata about a resource, +directly in the HTTP protocol. It is used to link resources to their +auxiliary resources, for instance. + +The following API is defined in @emph{(webid-oidc http-link)}: + +@deftp {Class} <link> @var{target-iri} @var{relation-type} @var{target-attributes} +The link refers to the @var{target-iri} that is being linked to the +requested resource, with a given @var{relation-type} (a string), and +optional additional @var{target-attributes}. + +When constructing a <link>, you should use the +@code{#:@var{target-iri}}, @code{#:@var{relation-type}} and +@code{#:@var{target-attributes}} keyword arguments +(@code{#:@var{target-attributes}} defaults to the empty list) to +initialize the link. For convenience, the @code{#:@var{anchor}}, +@code{#:@var{hreflang}}, @code{#:@var{media}}, @code{#:@var{title}}, +@code{#:@var{title*}} and @code{#:@var{type}} keyword arguments can be +passed to add well-known target attributes. +@end deftp + +@deftp {Class} <target-attribute> @var{key} @var{value} +If you wish to add new extension target attributes, you can create an +ad-hoc target attribute with @var{key} and @var{value} (initialized as +@code{#:@var{key}} and @code{#:@var{value}} constructor keyword +arguments). +@end deftp + +@deffn {Generic} target-iri @var{link} +@deffnx {Generic} relation-type @var{link} +@deffnx {Generic} target-attributes @var{link} +Getters for the @code{<link>} class. +@end deffn + +@deffn {Generic} key @var{target-attribute} +@deffnx {Generic} value @var{target-attribute} +Getters for the @code{<target-attribute>} class. +@end deffn + +@deffn {Generic} target-attribute @var{link} @var{key} +Return the value of the first target attributet with @var{key}. +@end deffn + +@deffn {Generic} anchor @var{link} +@deffnx {Generic} hreflang @var{link} +@deffnx {Generic} media @var{link} +@deffnx {Generic} title @var{link} +@deffnx {Generic} title* @var{link} +@deffnx {Generic} type @var{link} +Convenience attribute lookup functions. @code{anchor} returns an URI +referencce, the others return a string. +@end deffn + +@deffn {function} declare-link-header! +Declare functions to parse, validate and print HTTP Link headers with +the Guile web request / response API. +@end deffn + +@deffn {function} request-links @var{request} +@deffnx {function} response-links @var{response} +Return the list of links in @var{request} or @var{response}. +@end deffn + @node Content negociation @chapter Content negociation There are a number of different available syntaxes for RDF, some being diff --git a/po/disfluid.pot b/po/disfluid.pot index 5e6e2e9..1c36a1d 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: disfluid SNAPSHOT\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-10-07 12:28+0200\n" +"POT-Creation-Date: 2021-10-11 16:45+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <LL@li.org>\n" @@ -1052,6 +1052,50 @@ msgstr "" msgid "<p>You can only use the <emph>GET</emph> method on this resource.</p>" msgstr "" +#: src/scm/webid-oidc/http-link.scm:148 +msgid "the #:anchor parameter should be a string or an URI reference" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:159 +msgid "the #:hreflang parameter should be a string" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:170 +msgid "the #:media parameter should be a string" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:181 +msgid "the #:title parameter should be a string" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:192 +msgid "the #:title* parameter should be a string" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:203 +msgid "the #:type parameter should be a string" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:208 +msgid "#:target-iri and #:relation-type are required" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:216 +msgid "#:target-iri should be an URI reference" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:221 +msgid "#:relation-type should be a string" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:242 +msgid "the #:attribute-key parameter should be a string or symbol" +msgstr "" + +#: src/scm/webid-oidc/http-link.scm:247 +msgid "the #:attribute-value parameter should be a string or URI" +msgstr "" + #: src/scm/webid-oidc/identity-provider.scm:74 msgid "Warning: generating a new key pair." msgstr "" @@ -2,8 +2,8 @@ msgid "" msgstr "" "Project-Id-Version: webid-oidc 0.0.0\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-10-07 12:28+0200\n" -"PO-Revision-Date: 2021-10-05 22:56+0200\n" +"POT-Creation-Date: 2021-10-11 16:45+0200\n" +"PO-Revision-Date: 2021-10-11 16:45+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" "Language: fr\n" @@ -1157,6 +1157,54 @@ msgstr "" "<p>Vous pouvez uniquement utiliser la méthode <emph>GET</emph> pour cette " "ressource.</p>" +#: src/scm/webid-oidc/http-link.scm:148 +msgid "the #:anchor parameter should be a string or an URI reference" +msgstr "" +"le paramètre #:anchor doit être une chaîne de caractères ou une référence " +"d’URI" + +#: src/scm/webid-oidc/http-link.scm:159 +msgid "the #:hreflang parameter should be a string" +msgstr "le paramètre #:hreflang doit être une chaîne de caractères" + +#: src/scm/webid-oidc/http-link.scm:170 +msgid "the #:media parameter should be a string" +msgstr "le paramètre #:media doit être une chaîne de caractères" + +#: src/scm/webid-oidc/http-link.scm:181 +msgid "the #:title parameter should be a string" +msgstr "le paramètre #:title doit être une chaîne de caractères" + +#: src/scm/webid-oidc/http-link.scm:192 +msgid "the #:title* parameter should be a string" +msgstr "le paramètre title* doit être une chaîne de caractères" + +#: src/scm/webid-oidc/http-link.scm:203 +msgid "the #:type parameter should be a string" +msgstr "le paramètre #:type doit être une chaîne de caractères" + +#: src/scm/webid-oidc/http-link.scm:208 +msgid "#:target-iri and #:relation-type are required" +msgstr "#:target-iri et #:relation-type sont requis" + +#: src/scm/webid-oidc/http-link.scm:216 +msgid "#:target-iri should be an URI reference" +msgstr "#:target-iri doit être une référence d’IRI" + +#: src/scm/webid-oidc/http-link.scm:221 +msgid "#:relation-type should be a string" +msgstr "#:relation-type doit être une chaîne de caractères" + +#: src/scm/webid-oidc/http-link.scm:242 +msgid "the #:attribute-key parameter should be a string or symbol" +msgstr "" +"le paramètre #:attribute-key doit être une chaîne de caractères ou un symbole" + +#: src/scm/webid-oidc/http-link.scm:247 +msgid "the #:attribute-value parameter should be a string or URI" +msgstr "" +"le paramètre #:attribute-value doit être une chaîne de caractères ou une URI" + #: src/scm/webid-oidc/identity-provider.scm:74 msgid "Warning: generating a new key pair." msgstr "Attention : génération d'une nouvelle paire de clé." @@ -2751,15 +2799,11 @@ msgstr "Paramètres" #~ msgid "the client manifest should be a JSON object" #~ msgstr "le manifeste client doit être un objet JSON" -#, fuzzy, scheme-format -#~| msgid "cannot fetch a client manifest: ~a" #~ msgid "cannot fetch the client manifest ~s: ~a" -#~ msgstr "impossible de télécharger un manifeste client : ~a" +#~ msgstr "impossible de télécharger le manifeste client ~s : ~a" -#, fuzzy, scheme-format -#~| msgid "cannot fetch a client manifest: ~a" #~ msgid "cannot fetch the client manifest ~s" -#~ msgstr "impossible de télécharger un manifeste client : ~a" +#~ msgstr "impossible de télécharger le manifeste client ~s" #, scheme-format #~ msgid "" diff --git a/src/scm/webid-oidc/http-link.scm b/src/scm/webid-oidc/http-link.scm index f8a239a..80b4109 100644 --- a/src/scm/webid-oidc/http-link.scm +++ b/src/scm/webid-oidc/http-link.scm @@ -19,20 +19,235 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 peg) #:use-module (ice-9 atomic) + #:use-module (ice-9 match) #:use-module (web uri) #:use-module (web request) #:use-module (web response) #:use-module (web http) + #:use-module (webid-oidc web-i18n) + #:use-module (oop goops) #:declarative? #t #:export ( + <link> + target-iri ;; context-iri is not remembered because it does not + ;; only depend on the header values + relation-type + target-attributes + <target-attribute> + attribute-key + attribute-value + + anchor + hreflang + media + title + title* + type + target-attribute + declare-link-header! request-links response-links )) +(define-class <link> () + (target-iri #:init-keyword #:target-iri #:getter target-iri) + (relation-type #:init-keyword #:relation-type #:getter relation-type) + (target-attributes #:init-keyword #:target-attributes #:getter target-attributes)) + +(define-method (equal? (x <link>) (y <link>)) + (and (equal? (target-iri x) (target-iri y)) + (equal? (relation-type x) (relation-type y)) + (equal? (target-attributes x) (target-attributes y)))) + +(define-method (write (link <link>) port) + (format port "#<<link> target-iri=~s; relation-type=~s; target-attributes=~s>" + (uri->string (target-iri link)) + (relation-type link) + (target-attributes link))) + +(define-method (display (link <link>) port) + (format port "#<<link> target-iri=~a; relation-type=~a; target-attributes=~a>" + (uri->string (target-iri link)) + (relation-type link) + (target-attributes link))) + +(define-class <target-attribute> () + (attribute-key #:init-keyword #:attribute-key #:getter attribute-key) + (attribute-value #:init-keyword #:attribute-value #:getter attribute-value)) + +(define-method (equal? (x <target-attribute>) (y <target-attribute>)) + (and (equal? (attribute-key x) (attribute-key y)) + (equal? (attribute-value x) (attribute-value y)))) + +(define-method (write (target-attribute <target-attribute>) port) + (format port "#<<target-attribute> attribute-key=~s; attribute-value=~s>" + (attribute-key target-attribute) + (attribute-value target-attribute))) + +(define-method (display (target-attribute <target-attribute>) port) + (format port "#<<target-attribute> attribute-key=~a; attribute-value=~a>" + (attribute-key target-attribute) + (attribute-value target-attribute))) + +(define-method (target-attribute (link <link>) key) + (when (string? key) + (set! key (string->symbol key))) + (assq-ref + (map (lambda (attribute) + `(,(attribute-key attribute) . ,(attribute-value attribute))) + (target-attributes link)) + key)) + +(define-method (anchor (link <link>)) + (string->uri-reference + (target-attribute link 'anchor))) + +(define-method (hreflang (link <link>)) + (target-attribute link 'anchor)) + +(define-method (media (link <link>)) + (target-attribute link 'media)) + +(define-method (title (link <link>)) + (target-attribute link 'title)) + +(define-method (title* (link <link>)) + (target-attribute link 'title*)) + +(define-method (type (link <link>)) + (target-attribute link 'type)) + +(define-method (initialize (link <link>) initargs) + (next-method) + (let-keywords + initargs #t + ((target-iri #f) + (relation-type #f) + (target-attributes '()) + (anchor #f) + (hreflang #f) + (media #f) + (title #f) + (title* #f) + (type #f)) + (let ((extra-target-attributes + (append + (match anchor + ((or (? uri-reference? anchor) + (? string? (= string->uri-reference (? uri-reference? anchor)))) + (list (make <target-attribute> + #:attribute-key 'anchor + #:attribute-value (uri->string anchor)))) + ((? not anchor) '()) + (otherwise + (scm-error 'wrong-type-arg "make <link>" + (G_ "the #:anchor parameter should be a string or an URI reference") + '() + (list anchor)))) + (match hreflang + ((? string? hreflang) + (list (make <target-attribute> + #:attribute-key 'hreflang + #:attribute-value hreflang))) + ((? not hreflang) '()) + (otherwise + (scm-error 'wrong-type-arg "make <link>" + (G_ "the #:hreflang parameter should be a string") + '() + (list hreflang)))) + (match media + ((? string? media) + (list (make <target-attribute> + #:attribute-key 'media + #:attribute-value media))) + ((? not media) '()) + (otherwise + (scm-error 'wrong-type-arg "make <link>" + (G_ "the #:media parameter should be a string") + '() + (list media)))) + (match title + ((? string? title) + (list (make <target-attribute> + #:attribute-key 'title + #:attribute-value title))) + ((? not title) '()) + (otherwise + (scm-error 'wrong-type-arg "make <link>" + (G_ "the #:title parameter should be a string") + '() + (list title)))) + (match title* + ((? string? title*) + (list (make <target-attribute> + #:attribute-key 'title* + #:attribute-value title*))) + ((? not title*) '()) + (otherwise + (scm-error 'wrong-type-arg "make <link>" + (G_ "the #:title* parameter should be a string") + '() + (list title*)))) + (match type + ((? string? type) + (list (make <target-attribute> + #:attribute-key 'type + #:attribute-value type))) + ((? not type) '()) + (otherwise + (scm-error 'wrong-type-arg "make <link>" + (G_ "the #:type parameter should be a string") + '() + (list type))))))) + (unless (and target-iri relation-type) + (scm-error 'wrong-type-arg "make <link>" + (G_ "#:target-iri and #:relation-type are required") + '() + (list `(,target-iri . ,relation-type)))) + (when (string? target-iri) + (set! target-iri + (string->uri-reference target-iri))) + (unless (uri-reference? target-iri) + (scm-error 'wrong-type-arg "make <link>" + (G_ "#:target-iri should be an URI reference") + '() + (list target-iri))) + (unless (string? relation-type) + (scm-error 'wrong-type-arg "make <link>" + (G_ "#:relation-type should be a string") + '() + (list relation-type))) + (slot-set! link 'target-iri target-iri) + (slot-set! link 'relation-type relation-type) + (slot-set! link 'target-attributes `(,@extra-target-attributes ,@target-attributes))))) + +(define-method (initialize (attribute <target-attribute>) initargs) + (next-method) + (let-keywords + initargs #t + ((attribute-key #f) + (attribute-value #f)) + (when (string? attribute-key) + (set! attribute-key (string->symbol attribute-key)) + (slot-set! attribute 'attribute-key attribute-key)) + (when (uri? attribute-value) + (set! attribute-value (uri->string attribute-value)) + (slot-set! attribute 'attribute-value attribute-value)) + (unless (symbol? attribute-key) + (scm-error 'wrong-type-arg "make <target-attribute>" + (G_ "the #:attribute-key parameter should be a string or symbol") + '() + (list attribute-key))) + (unless (string? attribute-value) + (scm-error 'wrong-type-arg "make <target-attribute>" + (G_ "the #:attribute-value parameter should be a string or URI") + '() + (list attribute-value))))) + (define-peg-string-patterns "links <-- link (comma link)* link <-- uri-reference (semicolon parameter)* @@ -167,65 +382,113 @@ escape-return <-- '\\' 'r' value)) (fix (list datum)))) +(define make-link + (match-lambda + (((? uri-reference? target-iri) attributes ...) + (let examine-attributes ((attributes attributes) + (relation-type #f) + (extra-attributes '())) + (match attributes + (() + (make <link> + #:target-iri target-iri + #:relation-type relation-type + #:target-attributes (reverse extra-attributes))) + ((('rel . new-relation-type) attributes ...) + (examine-attributes attributes + (or relation-type new-relation-type) + extra-attributes)) + (((key . value) attributes ...) + (examine-attributes attributes relation-type + `(,(make <target-attribute> + #:attribute-key key + #:attribute-value value) + ,@extra-attributes)))))))) + (define (parse str) (let ((tree (peg:tree (match-pattern links str)))) - (and tree (fix tree)))) + (and tree + (let ((fixed (fix tree))) + (and fixed + (with-exception-handler + (lambda (exn) + (raise-exception exn)) + (lambda () + (map make-link fixed)))))))) (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)))) + (and links #t)) + +(define (escape-double str) + (let escape ((chars (string->list str)) + (escaped '())) + (match chars + (() (list->string (reverse escaped))) + ((#\return chars ...) + (escape chars `(#\r #\\ ,@escaped))) + ((#\newline chars ...) + (escape chars `(#\n #\\ ,@escaped))) + ((#\tab chars ...) + (escape chars `(#\t #\\ ,@escaped))) + (((and needs-escape + (or #\\ #\")) + chars ...) + (escape chars `(,needs-escape #\\ ,@escaped))) + ((c chars ...) + (escape chars `(,c ,@escaped)))))) + +(define-method (http-write (attribute <target-attribute>) port) + (format port + (if (string-suffix? "*" (symbol->string (attribute-key attribute))) + ;; Don’t put double quotes for title* and such + "~a=~a" + "~a=\"~a\"") + (attribute-key attribute) + (escape-double (attribute-value attribute)))) + +(define-method (http-write (link <link>) port) + (let escape-target-iri ((target-iri-chars + (string->list + (uri->string + (target-iri link)))) + (escaped-chars '())) + (match target-iri-chars + (() + (let ((target-iri-str + (list->string (reverse escaped-chars))) + (relation-type-str + (escape-double + (match (relation-type link) + ((or (? uri? (= uri->string uri)) + (? string? uri)) + uri)))) + (target-attributes-str + (map + (lambda (attr) + (call-with-output-string + (lambda (port) + (display "; " port) + (http-write attr port)))) + (target-attributes link)))) + (format port "<~a>; rel=\"~a\"~a" + target-iri-str relation-type-str + (string-join target-attributes-str "")))) + ((#\> target-iri-chars ...) + (escape-target-iri `(#\% #\3 #\E ,@target-iri-chars) + escaped-chars)) + ((c target-iri-chars ...) + (escape-target-iri target-iri-chars + `(,c ,@escaped-chars)))))) + +(define-method (http-write (links <list>) port) (display - (string-join (map write-one-link links) ", ") + (string-join + (map (lambda (link) + (call-with-output-string + (lambda (port) + (http-write link port)))) + links) + ", ") port)) (define (declare-link-header!) @@ -237,7 +500,7 @@ escape-return <-- '\\' 'r' "Link" parse validate - write))))) + http-write))))) (define (request-links request) (apply append diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index d035ec4..989abd9 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -247,10 +247,10 @@ (receive (content-type content) (nonrdf-or-turtle server-uri request request-body) (let ((types - (map car + (map target-iri (filter (lambda (link) - (equal? (assq-ref link 'rel) "type")) + (equal? (relation-type link) "type")) (request-links request))))) (return (build-response diff --git a/src/scm/webid-oidc/server/delete.scm b/src/scm/webid-oidc/server/delete.scm index 445622c..28a17df 100644 --- a/src/scm/webid-oidc/server/delete.scm +++ b/src/scm/webid-oidc/server/delete.scm @@ -21,7 +21,6 @@ #:use-module (webid-oidc server precondition) #:use-module (webid-oidc cache) #:use-module (webid-oidc fetch) - #:use-module (webid-oidc http-link) #:use-module (webid-oidc server resource wac) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) diff --git a/src/scm/webid-oidc/server/precondition.scm b/src/scm/webid-oidc/server/precondition.scm index 7e3a4bb..244e288 100644 --- a/src/scm/webid-oidc/server/precondition.scm +++ b/src/scm/webid-oidc/server/precondition.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 @@ -20,7 +20,6 @@ #:use-module (webid-oidc server resource content) #:use-module (webid-oidc cache) #:use-module (webid-oidc fetch) - #:use-module (webid-oidc http-link) #:use-module (webid-oidc server resource wac) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm index 73d32e3..f5a493b 100644 --- a/src/scm/webid-oidc/server/read.scm +++ b/src/scm/webid-oidc/server/read.scm @@ -112,51 +112,63 @@ ;; Headers (let ((links (let ((type - `(,(string->uri - (string-append "http://www.w3.org/ns/ldp#" - (if container? - "BasicContainer" - "Resource"))) - (rel . "type"))) + (make <link> + #:target-iri + (string-append "http://www.w3.org/ns/ldp#" + (if container? + "BasicContainer" + "Resource")) + #:relation-type "type")) (acl (and needs-acl? - `(,(build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "http://www.w3.org/ns/auth/acl#accessControl"))) - (rel . "acl")))) + (make <link> + #:target-iri + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "http://www.w3.org/ns/auth/acl#accessControl"))) + #:relation-type "acl"))) (describedby (and needs-meta? - `(,(build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) - (rel . "describedby")))) + (make <link> + #:target-iri + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) + #:relation-type "describedby"))) (describes (and needs-meta? - `(,(build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path base-path) - (rel . "https://www.w3.org/ns/iana/link-relations/relation#describes")))) + (make <link> + #:target-iri + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path base-path) + #:relation-type + "https://www.w3.org/ns/iana/link-relations/relation#describes"))) (storage (and root? - `((,(string->uri "http://www.w3.org/ns/pim/space#Storage") - (rel . "type")) - (,owner - (rel . "http://www.w3.org/ns/solid/terms#owner")))))) + (list + (make <link> + #:target-iri + "http://www.w3.org/ns/pim/space#Storage" + #:relation-type "type") + (make <link> + #:target-iri owner + #:relation-type "http://www.w3.org/ns/solid/terms#owner"))))) (append (list type) (if acl (list acl) '()) diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm index 9bca2e6..49ed1fe 100644 --- a/src/scm/webid-oidc/server/update.scm +++ b/src/scm/webid-oidc/server/update.scm @@ -22,7 +22,6 @@ #:use-module (webid-oidc server create) ;; for &unsupported-media-type #:use-module (webid-oidc cache) #:use-module (webid-oidc fetch) - #:use-module (webid-oidc http-link) #:use-module (webid-oidc server resource wac) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) diff --git a/tests/crud.scm b/tests/crud.scm index da3637a..38af286 100644 --- a/tests/crud.scm +++ b/tests/crud.scm @@ -23,6 +23,7 @@ #:use-module (webid-oidc server resource path) #:use-module (webid-oidc errors) #:use-module (webid-oidc testing) + #:use-module (webid-oidc http-link) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (webid-oidc fetch) #:use-module (webid-oidc rdf-index) @@ -31,6 +32,7 @@ #:use-module (web response) #:use-module (web uri) #:use-module (ice-9 receive) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:duplicates (merge-generics) #:declarative? #t) @@ -133,18 +135,38 @@ (accept-put (assq-ref headers-root 'accept-put)) (content-type (assq-ref headers-root 'content-type)) (etag (assq-ref headers-root 'etag))) - (unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/ldp#BasicContainer")) - '((rel . "type"))) - (exit 6)) - (unless (equal? (assoc-ref links (string->uri "https://example.com/.acl")) - '((rel . "acl"))) - (exit 7)) - (unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/pim/space#Storage")) - '((rel . "type"))) - (exit 8)) - (unless (equal? (assoc-ref links owner) - '((rel . "http://www.w3.org/ns/solid/terms#owner"))) - (exit 9)) + (let search-links ((links links) + (container-type-found? #f) + (acl-found? #f) + (storage-type-found? #f) + (owner-found? #f)) + (match links + ((link links ...) + (cond + ((and (equal? (target-iri link) (string->uri "http://www.w3.org/ns/ldp#BasicContainer")) + (equal? (relation-type link) "type")) + (search-links links #t acl-found? storage-type-found? owner-found?)) + ((and (equal? (target-iri link) (string->uri "https://example.com/.acl")) + (equal? (relation-type link) "acl")) + (search-links links container-type-found? #t storage-type-found? owner-found?)) + ((and (equal? (target-iri link) (string->uri "http://www.w3.org/ns/pim/space#Storage")) + (equal? (relation-type link) "type")) + (search-links links container-type-found? acl-found? #t owner-found?)) + ((and (equal? (target-iri link) owner) + (equal? (relation-type link) "http://www.w3.org/ns/solid/terms#owner")) + (search-links links container-type-found? acl-found? storage-type-found? #t)) + (else + (format (current-error-port) "Ignoring link: ~s\n" link) + (search-links links container-type-found? acl-found? storage-type-found? owner-found?)))) + (() + (unless container-type-found? + (exit 6)) + (unless acl-found? + (exit 7)) + (unless storage-type-found? + (exit 8)) + (unless owner-found? + (exit 9))))) (unless (and (memq 'GET allow) (memq 'HEAD allow) (memq 'OPTIONS allow) 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))))))))) |