summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-01-10 08:20:29 -0800
committerAndy Wingo <wingo@pobox.com>2011-01-10 09:31:29 -0800
commitecfb7167cbc239a4b4f11cb8287e8116c2760cff (patch)
treec6eff829dfa7e61ce5c0bdd288535e5358120177
parent94f16a5b8f51af91e273f9886e8ffa54eb3bd9c0 (diff)
downloadguile-ecfb7167cbc239a4b4f11cb8287e8116c2760cff.tar.gz
parse credentials and challenges
* module/web/http.scm (parse-credentials, validate-credentials) (write-credentials, parse-challenge, parse-challenges) (validate-challenges, write-challenge, write-challenges) (declare-credentials-header!, declare-challenge-list-header!): New helpers. ("Authorization", "Proxy-Authorization"): Parse out credentials. ("Proxy-Authenticate", "WWW-Authenticate"): Parse out challenges.
-rw-r--r--module/web/http.scm128
-rw-r--r--test-suite/tests/web-http.test16
2 files changed, 131 insertions, 13 deletions
diff --git a/module/web/http.scm b/module/web/http.scm
index d2117145b..8298505d0 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -677,6 +677,108 @@ ordered alist."
(define (write-entity-tag-list val port)
(write-list val port write-entity-tag ", "))
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
+;;
+;; That's what the spec says. In reality the Basic scheme doesn't have
+;; k-v pairs, just one auth token, so we give that token as a string.
+;;
+(define* (parse-credentials str #:optional (val-parser default-val-parser)
+ (start 0) (end (string-length str)))
+ (let* ((start (skip-whitespace str start end))
+ (delim (or (string-index str char-whitespace? start end) end)))
+ (if (= start end)
+ (bad-header-component 'authorization str))
+ (let ((scheme (string->symbol
+ (string-downcase (substring str start (or delim end))))))
+ (case scheme
+ ((basic)
+ (let* ((start (skip-whitespace str delim end)))
+ (if (< start end)
+ (cons scheme (substring str start end))
+ (bad-header-component 'credentials str))))
+ (else
+ (cons scheme (parse-key-value-list str default-val-parser delim end)))))))
+
+(define (validate-credentials val)
+ (and (pair? val) (symbol? (car val)) (key-value-list? (cdr val))))
+
+(define (write-credentials val port)
+ (display (car val) port)
+ (if (pair? (cdr val))
+ (begin
+ (display #\space port)
+ (write-key-value-list (cdr val) port))))
+
+;; challenges = 1#challenge
+;; challenge = auth-scheme 1*SP 1#auth-param
+;;
+;; A pain to parse, as both challenges and auth params are delimited by
+;; commas, and qstrings can contain anything. We rely on auth params
+;; necessarily having "=" in them.
+;;
+(define* (parse-challenge str #:optional
+ (start 0) (end (string-length str)))
+ (let* ((start (skip-whitespace str start end))
+ (sp (string-index str #\space start end))
+ (scheme (if sp
+ (string->symbol (string-downcase (substring str start sp)))
+ (bad-header-component 'challenge str))))
+ (let lp ((i sp) (out (list scheme)))
+ (if (not (< i end))
+ (values (reverse! out) end)
+ (let* ((i (skip-whitespace str i end))
+ (eq (string-index str #\= i end))
+ (comma (string-index str #\, i end))
+ (delim (min (or eq end) (or comma end)))
+ (token-end (trim-whitespace str i delim)))
+ (if (string-index str #\space i token-end)
+ (values (reverse! out) i)
+ (let ((k (string->symbol (substring str i token-end))))
+ (call-with-values
+ (lambda ()
+ (if (and eq (or (not comma) (< eq comma)))
+ (let ((i (skip-whitespace str (1+ eq) end)))
+ (if (and (< i end) (eqv? (string-ref str i) #\"))
+ (parse-qstring str i end #:incremental? #t)
+ (values (substring
+ str i
+ (trim-whitespace str i
+ (or comma end)))
+ (or comma end))))
+ (values #f delim)))
+ (lambda (v next-i)
+ (let ((i (skip-whitespace str next-i end)))
+ (if (or (= i end) (eqv? (string-ref str i) #\,))
+ (lp (1+ i) (cons (if v (cons k v) k) out))
+ (bad-header-component
+ 'challenge
+ (substring str start end)))))))))))))
+
+(define* (parse-challenges str #:optional (val-parser default-val-parser)
+ (start 0) (end (string-length str)))
+ (let lp ((i start) (ret '()))
+ (let ((i (skip-whitespace str i end)))
+ (if (< i end)
+ (call-with-values (lambda () (parse-challenge str i end))
+ (lambda (challenge i)
+ (lp i (cons challenge ret))))
+ (reverse ret)))))
+
+(define (validate-challenges val)
+ (list-of? val (lambda (x)
+ (and (pair? x) (symbol? (car x))
+ (key-value-list? (cdr x))))))
+
+(define (write-challenge val port)
+ (display (car val) port)
+ (display #\space port)
+ (write-key-value-list (cdr val) port))
+
+(define (write-challenges val port)
+ (write-list val port write-challenge ", "))
+
@@ -922,6 +1024,16 @@ phrase\"."
(display "*" port)
(write-entity-tag-list val port)))))
+;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1)
+(define (declare-credentials-header! name)
+ (declare-header! name
+ parse-credentials validate-credentials write-credentials))
+
+;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1)
+(define (declare-challenge-list-header! name)
+ (declare-header! name
+ parse-challenges validate-challenges write-challenges))
+
@@ -1262,11 +1374,11 @@ phrase\"."
(declare-quality-list-header! "Accept-Language")
;; Authorization = credentials
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
;;
-;; Authorization is basically opaque to this HTTP stack, we just pass
-;; the string value through.
-;;
-(declare-opaque-header! "Authorization")
+(declare-credentials-header! "Authorization")
;; Expect = 1#expectation
;; expectation = "100-continue" | expectation-extension
@@ -1340,7 +1452,7 @@ phrase\"."
;; Proxy-Authorization = credentials
;;
-(declare-opaque-header! "Proxy-Authorization")
+(declare-credentials-header! "Proxy-Authorization")
;; Range = "Range" ":" ranges-specifier
;; ranges-specifier = byte-ranges-specifier
@@ -1437,8 +1549,7 @@ phrase\"."
;; Proxy-Authenticate = 1#challenge
;;
-;; FIXME: split challenges ?
-(declare-opaque-header! "Proxy-Authenticate")
+(declare-challenge-list-header! "Proxy-Authenticate")
;; Retry-After = ( HTTP-date | delta-seconds )
;;
@@ -1475,5 +1586,4 @@ phrase\"."
;; WWW-Authenticate = 1#challenge
;;
-;; Hum.
-(declare-opaque-header! "WWW-Authenticate")
+(declare-challenge-list-header! "WWW-Authenticate")
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index ecefe7c00..c191c6eab 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -149,7 +149,10 @@
'((1000 . "da") (800 . "en-gb") (700 . "en")))
;; Allow nonstandard .2 to mean 0.2
(pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
- (pass-if-parse authorization "foo" "foo")
+ (pass-if-parse authorization "Basic foooo" '(basic . "foooo"))
+ (pass-if-parse authorization "Digest foooo" '(digest foooo))
+ (pass-if-parse authorization "Digest foo=bar,baz=qux"
+ '(digest (foo . "bar") (baz . "qux")))
(pass-if-parse expect "100-continue, foo" '((100-continue) (foo)))
(pass-if-parse from "foo@bar" "foo@bar")
(pass-if-parse host "qux" '("qux" . #f))
@@ -172,7 +175,10 @@
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
(pass-if-parse max-forwards "10" 10)
(pass-if-parse max-forwards "00" 0)
- (pass-if-parse proxy-authorization "foo" "foo")
+ (pass-if-parse proxy-authorization "Basic foooo" '(basic . "foooo"))
+ (pass-if-parse proxy-authorization "Digest foooo" '(digest foooo))
+ (pass-if-parse proxy-authorization "Digest foo=bar,baz=qux"
+ '(digest (foo . "bar") (baz . "qux")))
(pass-if-parse range "bytes=10-20" '(bytes (10 . 20)))
(pass-if-parse range "bytes=10-" '(bytes (10 . #f)))
(pass-if-parse range "bytes=-20" '(bytes (#f . 20)))
@@ -193,7 +199,8 @@
(pass-if-parse etag "W/\"foo\"" '("foo" . #f))
(pass-if-parse location "http://other-place"
(build-uri 'http #:host "other-place"))
- (pass-if-parse proxy-authenticate "ho-hum" "ho-hum")
+ (pass-if-parse proxy-authenticate "Basic realm=\"guile\""
+ '((basic (realm . "guile"))))
(pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
@@ -201,4 +208,5 @@
(pass-if-parse server "guile!" "guile!")
(pass-if-parse vary "*" '*)
(pass-if-parse vary "foo, bar" '(foo bar))
- (pass-if-parse www-authenticate "secret" "secret"))
+ (pass-if-parse www-authenticate "Basic realm=\"guile\""
+ '((basic (realm . "guile")))))