From e270db06bdce0a5725f41c6529febb3bc84a4a9c Mon Sep 17 00:00:00 2001
From: Vasilij Schneidermann <mail@vasilij.de>
Date: Thu, 28 May 2020 21:58:42 +0200
Subject: [PATCH] Add support for bearer auth

---
 intarweb/2.0.1/header-parsers.scm | 14 ++++++++++++--
 intarweb/2.0.1/intarweb.scm       |  2 ++
 intarweb/2.0.1/tests/run.scm      | 12 ++++++++++++
 3 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/intarweb/2.0.1/header-parsers.scm b/intarweb/2.0.1/header-parsers.scm
index 89edeae..4fc4771 100644
--- a/intarweb/2.0.1/header-parsers.scm
+++ b/intarweb/2.0.1/header-parsers.scm
@@ -568,9 +568,15 @@
                   (algorithm . ,symbol-subparser-ci))
                 (char-set #\,) (char-set #\, #\=)))
 
+(define (bearer-auth-param-subparser contents pos)
+  (receive (token pos)
+      (parse-token contents pos char-set:whitespace)
+    (values `((token . ,token)) pos)))
+
 (define authorization-param-subparsers
   (make-parameter `((basic . ,basic-auth-param-subparser)
-                    (digest . ,digest-auth-param-subparser))))
+                    (digest . ,digest-auth-param-subparser)
+                    (bearer . ,bearer-auth-param-subparser))))
 
 (define (authorization-parser contents)
   (let loop ((pos 0)
@@ -934,9 +940,13 @@
                         (string-pad (number->string x 16) 8 #\0)
                         (quote-string (->string x))))))
 
+(define (bearer-auth-param-subunparser params)
+  (alist-ref 'token params))
+
 (define authorization-param-subunparsers
   (make-parameter `((basic . ,basic-auth-param-subunparser)
-                    (digest . ,digest-auth-param-subunparser))))
+                    (digest . ,digest-auth-param-subunparser)
+                    (bearer . ,bearer-auth-param-subunparser))))
 
 (define (authorization-unparser header-contents)
   (map (lambda (header)
diff --git a/intarweb/2.0.1/intarweb.scm b/intarweb/2.0.1/intarweb.scm
index 3df4690..ba54b5f 100644
--- a/intarweb/2.0.1/intarweb.scm
+++ b/intarweb/2.0.1/intarweb.scm
@@ -95,9 +95,11 @@
    ;; Subparsers/subunparsers
    authorization-param-subparsers
    basic-auth-param-subparser digest-auth-param-subparser
+   bearer-auth-param-subparser
    
    authorization-param-subunparsers
    basic-auth-param-subunparser digest-auth-param-subunparser
+   bearer-auth-param-subunparser
    )
 
 (import scheme (chicken base) (chicken foreign) (chicken irregex)
diff --git a/intarweb/2.0.1/tests/run.scm b/intarweb/2.0.1/tests/run.scm
index d97f15d..a56ebd0 100644
--- a/intarweb/2.0.1/tests/run.scm
+++ b/intarweb/2.0.1/tests/run.scm
@@ -221,6 +221,14 @@
         (test "algorithm"
               'md5
               (header-param 'algorithm 'authorization headers))))
+    (test-group "bearer auth"
+      (let ((headers (test-read-headers "Authorization: Bearer AbCdEf123456\r\n")))
+        (test "bearer"
+              'bearer
+              (header-value 'authorization headers))
+        (test "token"
+              "AbCdEf123456"
+              (header-param 'token 'authorization headers))))
     (test-group "custom authorization scheme"
       (parameterize ((authorization-param-subparsers
                       `((custom . ,(lambda (contents pos)
@@ -771,6 +779,10 @@
                                (opaque . "5ccc069c403ebaf9f0171e9517f40e41")
                                (nc . 1)
                                (algorithm . md5)))))))
+    (test "Bearer auth"
+          "Authorization: Bearer AbCdEf123456\r\n"
+          (test-unparse-headers
+           `((authorization #(bearer ((token . "AbCdEf123456")))))))
     (test "Custom auth"
           "Authorization: Custom some-random-contents\r\n"
           (parameterize ((authorization-param-subunparsers
-- 
2.26.2