;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(define-module (webid-oidc http-link)
#:use-module (ice-9 receive)
#: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)*
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 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
(let ((fixed (fix tree)))
(and fixed
(with-exception-handler
(lambda (exn)
(raise-exception exn))
(lambda ()
(map make-link fixed))))))))
(define (validate links)
(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 (lambda (link)
(call-with-output-string
(lambda (port)
(http-write link port))))
links)
", ")
port))
(define (declare-link-header!)
(let ((storage (make-atomic-box #f)))
(let ((not-declared-yet?
(atomic-box-compare-and-swap! storage #f #t)))
(unless not-declared-yet?
(declare-header!
"Link"
parse
validate
http-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))))