diff options
Diffstat (limited to 'src/scm/webid-oidc/http-link.scm')
| -rw-r--r-- | src/scm/webid-oidc/http-link.scm | 373 |
1 files changed, 318 insertions, 55 deletions
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 |