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

(define-module (webid-oidc http-link)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 peg)
  #:use-module (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web http)
  #:export
  (

   declare-link-header!
   request-links
   response-links

   ))

(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 (parse str)
  (let ((tree (peg:tree (match-pattern links str))))
    (and tree (fix tree))))

(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))))
  (display
   (string-join (map write-one-link links) ", ")
   port))

(define (declare-link-header!)
  (declare-header!
   "Link"
   parse
   validate
   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))))