From c945e27465532d768cc6012c8737f4c74b59fd9e Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Mon, 11 Oct 2021 12:42:13 +0200 Subject: HTTP Link header: use GOOPS and document it --- src/scm/webid-oidc/http-link.scm | 373 ++++++++++++++++++++++++----- src/scm/webid-oidc/resource-server.scm | 4 +- src/scm/webid-oidc/server/delete.scm | 1 - src/scm/webid-oidc/server/precondition.scm | 3 +- src/scm/webid-oidc/server/read.scm | 86 ++++--- src/scm/webid-oidc/server/update.scm | 1 - 6 files changed, 370 insertions(+), 98 deletions(-) (limited to 'src/scm/webid-oidc') 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 ( + + target-iri ;; context-iri is not remembered because it does not + ;; only depend on the header values + relation-type + target-attributes + + attribute-key + attribute-value + + anchor + hreflang + media + title + title* + type + target-attribute + declare-link-header! request-links response-links )) +(define-class () + (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 ) (y )) + (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 ) port) + (format port "#< target-iri=~s; relation-type=~s; target-attributes=~s>" + (uri->string (target-iri link)) + (relation-type link) + (target-attributes link))) + +(define-method (display (link ) port) + (format port "#< target-iri=~a; relation-type=~a; target-attributes=~a>" + (uri->string (target-iri link)) + (relation-type link) + (target-attributes link))) + +(define-class () + (attribute-key #:init-keyword #:attribute-key #:getter attribute-key) + (attribute-value #:init-keyword #:attribute-value #:getter attribute-value)) + +(define-method (equal? (x ) (y )) + (and (equal? (attribute-key x) (attribute-key y)) + (equal? (attribute-value x) (attribute-value y)))) + +(define-method (write (target-attribute ) port) + (format port "#< attribute-key=~s; attribute-value=~s>" + (attribute-key target-attribute) + (attribute-value target-attribute))) + +(define-method (display (target-attribute ) port) + (format port "#< attribute-key=~a; attribute-value=~a>" + (attribute-key target-attribute) + (attribute-value target-attribute))) + +(define-method (target-attribute (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 )) + (string->uri-reference + (target-attribute link 'anchor))) + +(define-method (hreflang (link )) + (target-attribute link 'anchor)) + +(define-method (media (link )) + (target-attribute link 'media)) + +(define-method (title (link )) + (target-attribute link 'title)) + +(define-method (title* (link )) + (target-attribute link 'title*)) + +(define-method (type (link )) + (target-attribute link 'type)) + +(define-method (initialize (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 + #:attribute-key 'anchor + #:attribute-value (uri->string anchor)))) + ((? not anchor) '()) + (otherwise + (scm-error 'wrong-type-arg "make " + (G_ "the #:anchor parameter should be a string or an URI reference") + '() + (list anchor)))) + (match hreflang + ((? string? hreflang) + (list (make + #:attribute-key 'hreflang + #:attribute-value hreflang))) + ((? not hreflang) '()) + (otherwise + (scm-error 'wrong-type-arg "make " + (G_ "the #:hreflang parameter should be a string") + '() + (list hreflang)))) + (match media + ((? string? media) + (list (make + #:attribute-key 'media + #:attribute-value media))) + ((? not media) '()) + (otherwise + (scm-error 'wrong-type-arg "make " + (G_ "the #:media parameter should be a string") + '() + (list media)))) + (match title + ((? string? title) + (list (make + #:attribute-key 'title + #:attribute-value title))) + ((? not title) '()) + (otherwise + (scm-error 'wrong-type-arg "make " + (G_ "the #:title parameter should be a string") + '() + (list title)))) + (match title* + ((? string? title*) + (list (make + #:attribute-key 'title* + #:attribute-value title*))) + ((? not title*) '()) + (otherwise + (scm-error 'wrong-type-arg "make " + (G_ "the #:title* parameter should be a string") + '() + (list title*)))) + (match type + ((? string? type) + (list (make + #:attribute-key 'type + #:attribute-value type))) + ((? not type) '()) + (otherwise + (scm-error 'wrong-type-arg "make " + (G_ "the #:type parameter should be a string") + '() + (list type))))))) + (unless (and target-iri relation-type) + (scm-error 'wrong-type-arg "make " + (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 " + (G_ "#:target-iri should be an URI reference") + '() + (list target-iri))) + (unless (string? relation-type) + (scm-error 'wrong-type-arg "make " + (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 ) 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 " + (G_ "the #:attribute-key parameter should be a string or symbol") + '() + (list attribute-key))) + (unless (string? attribute-value) + (scm-error 'wrong-type-arg "make " + (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 + #: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 + #: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 ) 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 ) 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 ) 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 + #: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 + #: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 + #: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 + #: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 + #:target-iri + "http://www.w3.org/ns/pim/space#Storage" + #:relation-type "type") + (make + #: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) -- cgit v1.2.3