mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 12:10:26 +02:00
Code Activity

parse credentials and challenges

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-01-10 08:20:29 -08:00
parent 94f16a5b8f
commit ecfb7167cb
2 changed files with 131 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

128
module/web/http.scm
View file

@ -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")

16
test-suite/tests/web-http.test
View file

@ -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")))))