diff options
author | Andy Wingo <wingo@pobox.com> | 2011-01-10 08:20:29 -0800 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-01-10 09:31:29 -0800 |
commit | ecfb7167cbc239a4b4f11cb8287e8116c2760cff (patch) | |
tree | c6eff829dfa7e61ce5c0bdd288535e5358120177 | |
parent | 94f16a5b8f51af91e273f9886e8ffa54eb3bd9c0 (diff) | |
download | guile-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.scm | 128 | ||||
-rw-r--r-- | test-suite/tests/web-http.test | 16 |
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"))))) |