path: root/src/scm/webid-oidc/http-link.scm

;; 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 <https://www.gnu.org/licenses/>.

(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
  (

   <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)*
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 <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
         (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 <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 (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))))