From c88a732bdae09eae0b39d0c8194da9aaeb4727d7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Aug 2005 19:51:28 +0000 Subject: [PATCH] Refactoring dispatcher and structs svn: r677 --- collects/web-server/connection-manager.ss | 13 +- collects/web-server/connection-structs.ss | 12 ++ collects/web-server/dispatch-passwords.ss | 114 +++++++++++++++++ collects/web-server/dispatch.ss | 9 ++ collects/web-server/request-parsing.ss | 22 +--- collects/web-server/request-structs.ss | 25 ++++ collects/web-server/response-structs.ss | 67 ++++++++++ collects/web-server/response.ss | 66 +--------- collects/web-server/servlet-helpers.ss | 14 +-- collects/web-server/servlet.ss | 1 - collects/web-server/timer-structs.ss | 6 + collects/web-server/timer.ss | 3 +- collects/web-server/util.ss | 30 ++++- collects/web-server/web-server-unit.ss | 142 +++------------------- 14 files changed, 295 insertions(+), 229 deletions(-) create mode 100644 collects/web-server/connection-structs.ss create mode 100644 collects/web-server/dispatch-passwords.ss create mode 100644 collects/web-server/dispatch.ss create mode 100644 collects/web-server/request-structs.ss create mode 100644 collects/web-server/response-structs.ss create mode 100644 collects/web-server/timer-structs.ss diff --git a/collects/web-server/connection-manager.ss b/collects/web-server/connection-manager.ss index 9a662aaa0b..6003d8d07a 100644 --- a/collects/web-server/connection-manager.ss +++ b/collects/web-server/connection-manager.ss @@ -3,17 +3,12 @@ ;; the queued-model is also fully implemented but won't be used at this time. (module connection-manager mzscheme - (require "timer.ss" + (require "connection-structs.ss" + "timer.ss" (lib "contract.ss")) - - (define-struct connection (timer i-port o-port custodian close? mutex) - (make-inspector)) - + (provide (all-from "connection-structs.ss")) + (provide/contract - [struct connection - ([timer timer?] - [i-port input-port?] [o-port output-port?] [custodian custodian?] - [close? boolean?] [mutex semaphore?])] [start-connection-manager (custodian? . -> . void)] [new-connection (number? input-port? output-port? custodian? boolean? . -> . connection?)] [kill-connection! (connection? . -> . void)] diff --git a/collects/web-server/connection-structs.ss b/collects/web-server/connection-structs.ss new file mode 100644 index 0000000000..c921bed35d --- /dev/null +++ b/collects/web-server/connection-structs.ss @@ -0,0 +1,12 @@ +(module connection-structs mzscheme + (require (lib "contract.ss")) + (require "timer-structs.ss") + + (define-struct connection (timer i-port o-port custodian close? mutex) + (make-inspector)) + + (provide/contract + [struct connection + ([timer timer?] + [i-port input-port?] [o-port output-port?] [custodian custodian?] + [close? boolean?] [mutex semaphore?])])) \ No newline at end of file diff --git a/collects/web-server/dispatch-passwords.ss b/collects/web-server/dispatch-passwords.ss new file mode 100644 index 0000000000..2459d4d08c --- /dev/null +++ b/collects/web-server/dispatch-passwords.ss @@ -0,0 +1,114 @@ +(module dispatch-passwords mzscheme + (require "dispatch.ss" + "util.ss" + "servlet-helpers.ss" + "connection-manager.ss" + "response.ss" + "configuration-structures.ss") + + (provide interface-version + gen-dispatcher + read-passwords) + + (define interface-version 'v1) + (define (gen-dispatcher host-info config:access next-dispatcher) + (lambda (conn req) + (let-values ([(uri method path) (decompose-request req)]) + (cond + [(access-denied? method path (request-headers req) host-info config:access) + => (lambda (realm) + (adjust-connection-timeout! conn (timeouts-password (host-timeouts host-info))) + (request-authentication conn method uri host-info realm))] + [else + (next-dispatcher conn req)])))) + + ;; **************************************** + ;; **************************************** + ;; ACCESS CONTROL + + ;; pass-entry = (make-pass-entry str regexp (list sym str)) + (define-struct pass-entry (domain pattern users)) + + ;; access-denied? : Method string x-table host Access-table -> (+ false str) + ;; the return string is the prompt for authentication + (define (access-denied? method uri-str headers host-info access-table) + ;; denied?: str sym str -> (U str #f) + ;; a function to authenticate the user + (let ([denied? + + ;; GregP lookup the authenticator function, if you can't find it, then try to load the + ;; passwords file for this host. + (hash-table-get + access-table host-info + (lambda () + ; more here - a malformed password file will kill the connection + (let ([f (read-passwords host-info)]) + (hash-table-put! access-table host-info f) + f)))]) + (let ([user-pass (extract-user-pass headers)]) + (if user-pass + (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass)) + (denied? uri-str fake-user ""))))) + + (define-struct (exn:password-file exn) ()) + + ;; : host -> (str sym str -> (U str #f)) + ;; to produce a function that checks if a given url path is accessible by a given user with a given + ;; password. If not, the produced function returns a string, prompting for the password. + ;; If the password file does not exist, all accesses are allowed. If the file is malformed, an + ;; exn:password-file is raised. + (define (read-passwords host-info) + (let ([password-path (host-passwords host-info)]) + (with-handlers ([void (lambda (exn) + (raise (make-exn:password-file (format "could not load password file ~a" password-path) + (current-continuation-marks))))]) + (if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path))) + (let ([passwords + (let ([raw (load password-path)]) + (unless (password-list? raw) + (raise "malformed passwords")) + (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x))) + raw))]) + + ;; string symbol bytes -> (union #f string) + (lambda (request-path user-name password) + (ormap (lambda (x) + (and (regexp-match (pass-entry-pattern x) request-path) + (let ([name-pass (assq user-name (pass-entry-users x))]) + (if (and name-pass + (string=? + (cadr name-pass) + (bytes->string/utf-8 password))) + #f + (pass-entry-domain x))))) + passwords))) + (lambda (req user pass) #f))))) + + (define fake-user (gensym)) + + ;; password-list? : TST -> bool + + ;; Note: andmap fails for dotted pairs at end. + ;; This is okay, since #f ends up raising a caught exception anyway. + (define (password-list? passwords) + (and (list? passwords) + (andmap (lambda (domain) + (and (pair? domain) (pair? (cdr domain)) (list (cddr domain)) + (string? (car domain)) + (string? (cadr domain)) + (andmap (lambda (x) + (and (pair? x) (pair? (cdr x)) (null? (cddr x)) + (symbol? (car x)) (string? (cadr x)))) + (cddr domain)))) + passwords))) + + ;; request-authentication : connection Method URL iport oport host str bool -> bool + ;; GregP: at first look, it seems that this gets called when the user + ;; has supplied bad authentication credentials. + (define (request-authentication conn method uri host-info realm) + (output-response/method + conn + ((responders-authentication (host-responders host-info)) + uri `(WWW-Authenticate . ,(string-append " Basic + realm=\"" realm "\""))) + method))) \ No newline at end of file diff --git a/collects/web-server/dispatch.ss b/collects/web-server/dispatch.ss new file mode 100644 index 0000000000..56f608ed03 --- /dev/null +++ b/collects/web-server/dispatch.ss @@ -0,0 +1,9 @@ +(module dispatch mzscheme + (require "connection-structs.ss" + "request-structs.ss" + "response-structs.ss") + (require (lib "contract.ss")) + + (provide dispatcher?) + + (define dispatcher? (connection? request? . -> . response?))) \ No newline at end of file diff --git a/collects/web-server/request-parsing.ss b/collects/web-server/request-parsing.ss index 4d5cb4d65b..76ef64f79f 100644 --- a/collects/web-server/request-parsing.ss +++ b/collects/web-server/request-parsing.ss @@ -5,33 +5,15 @@ "util.ss" "connection-manager.ss" (lib "port.ss") - ) - - ;; the request struct as currently doc'd - (define-struct request (method uri headers bindings host-ip client-ip)) + "request-structs.ss") + (provide (all-from "request-structs.ss")) ;; path-prefix: (listof string) ;; The part of the URL path that maps to the servlet ;; path-suffix: (listof string) ;; The part of the URL path that gets passed to the servlet as arguments. - ;; header?: anyd/c -> boolean - ;; is this a header? - (define header? - (cons/c symbol? bytes?)) - - ;; bindings? any/c -> boolean - ;; is this a binding - (define binding? - (cons/c symbol? - (union string? - bytes?))) - (provide/contract - [struct request ([method symbol?] [uri url?] [headers (listof header?)] - [bindings (union (listof binding?) string?)] - [host-ip string?] - [client-ip string?])] [read-request ((connection?) . ->* . (request? boolean?))] [read-bindings (connection? symbol? url? (listof header?) . -> . (union (listof binding?) string?))]) diff --git a/collects/web-server/request-structs.ss b/collects/web-server/request-structs.ss new file mode 100644 index 0000000000..0b2534f328 --- /dev/null +++ b/collects/web-server/request-structs.ss @@ -0,0 +1,25 @@ +(module request-structs mzscheme + (require (lib "contract.ss") + (lib "url.ss" "net")) + + ;; the request struct as currently doc'd + (define-struct request (method uri headers bindings/raw host-ip client-ip)) + + ;; header?: anyd/c -> boolean + ;; is this a header? + (define header? + (cons/c symbol? bytes?)) + + ;; bindings? any/c -> boolean + ;; is this a binding + (define binding? + (cons/c symbol? + (union string? + bytes?))) + + (provide header? binding?) + (provide/contract + [struct request ([method symbol?] [uri url?] [headers (listof header?)] + [bindings/raw (union (listof binding?) string?)] + [host-ip string?] + [client-ip string?])])) \ No newline at end of file diff --git a/collects/web-server/response-structs.ss b/collects/web-server/response-structs.ss new file mode 100644 index 0000000000..ff57ea9149 --- /dev/null +++ b/collects/web-server/response-structs.ss @@ -0,0 +1,67 @@ +(module response-structs mzscheme + (require (lib "contract.ss") + (lib "xml.ss" "xml")) + + ;; ************************************************** + ;; (make-response/basic number string number string (listof (cons symbol string))) + (define-struct response/basic (code message seconds mime extras)) + ;; (make-response/full ... (listof string)) + (define-struct (response/full response/basic) (body)) + ;; (make-response/incremental ... ((string* -> void) -> void)) + (define-struct (response/incremental response/basic) (generator)) + + ; response = (cons string (listof string)), where the first string is a mime-type + ; | x-expression + ; | (make-response/full ... (listof string)) + ; | (make-response/incremental ... ((string* -> void) -> void)) + + ;; ************************************************** + ;; response?: any -> boolean + ;; Determine if an object is a response + (define (response? x) + (or (and (response/basic? x) + (number? (response/basic-code x)) + (string? (response/basic-message x)) + (number? (response/basic-seconds x)) + (bytes? (response/basic-mime x)) + (and (list? (response/basic-extras x)) + (andmap + (lambda (p) + (and (pair? p) + (symbol? (car p)) + (string? (cdr p)))) + (response/basic-extras x)))) + ; this could fail for dotted lists - rewrite andmap + (and (pair? x) (pair? (cdr x)) (andmap + (lambda (x) + (or (string? x) + (bytes? x))) + x)) + ; insist that the xexpr has a root element + (and (pair? x) (xexpr? x)))) + + + (provide/contract + [struct response/basic + ([code number?] + [message string?] + [seconds number?] + [mime bytes?] + [extras (listof (cons/c symbol? string?))])] + [struct (response/full response/basic) + ([code number?] + [message string?] + [seconds number?] + [mime bytes?] + [extras (listof (cons/c symbol? string?))] + [body (listof (union string? + bytes?))])] + [struct (response/incremental response/basic) + ([code number?] + [message string?] + [seconds number?] + [mime bytes?] + [extras (listof (cons/c symbol? string?))] + [generator ((() (listof (union bytes? string?)) . ->* . any) . -> + . any)])] + [response? (any/c . -> . boolean?)])) \ No newline at end of file diff --git a/collects/web-server/response.ss b/collects/web-server/response.ss index 5c567c9690..0518a4093e 100644 --- a/collects/web-server/response.ss +++ b/collects/web-server/response.ss @@ -6,75 +6,13 @@ (lib "xml.ss" "xml") (lib "string.ss" "srfi" "13") "connection-manager.ss" + "response-structs.ss" "util.ss") - - ;; ************************************************** - ;; DATA DEF for response - ;; (make-response/basic number string number string (listof (cons symbol string))) - (define-struct response/basic (code message seconds mime extras)) - ;; (make-response/full ... (listof string)) - (define-struct (response/full response/basic) (body)) - ;; (make-response/incremental ... ((string* -> void) -> void)) - (define-struct (response/incremental response/basic) (generator)) - - ; response = (cons string (listof string)), where the first string is a mime-type - ; | x-expression - ; | (make-response/full ... (listof string)) - ; | (make-response/incremental ... ((string* -> void) -> void)) - - ;; ************************************************** - ;; response?: any -> boolean - ;; Determine if an object is a response - (define (response? x) - (or (and (response/basic? x) - (number? (response/basic-code x)) - (string? (response/basic-message x)) - (number? (response/basic-seconds x)) - (bytes? (response/basic-mime x)) - (and (list? (response/basic-extras x)) - (andmap - (lambda (p) - (and (pair? p) - (symbol? (car p)) - (string? (cdr p)))) - (response/basic-extras x)))) - ; this could fail for dotted lists - rewrite andmap - (and (pair? x) (pair? (cdr x)) (andmap - (lambda (x) - (or (string? x) - (bytes? x))) - x)) - ; insist that the xexpr has a root element - (and (pair? x) (xexpr? x)))) - + (provide (all-from "response-structs.ss")) ;; Weak contracts for output-response because the response? is checked inside ;; output-response, handled, etc. (provide/contract - [struct response/basic - ([code number?] - [message string?] - [seconds number?] - [mime bytes?] - [extras (listof (cons/c symbol? string?))])] - [struct (response/full response/basic) - ([code number?] - [message string?] - [seconds number?] - [mime bytes?] - [extras (listof (cons/c symbol? string?))] - [body (listof (union string? - bytes?))])] - [struct (response/incremental response/basic) - ([code number?] - [message string?] - [seconds number?] - [mime bytes?] - [extras (listof (cons/c symbol? string?))] - [generator ((() (listof (union bytes? string?)) . ->* . any) . -> - . any)] - )] - [response? (any/c . -> . boolean?)] [rename ext:output-response output-response (connection? any/c . -> . any)] [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . any)] [rename ext:output-file output-file (connection? path? symbol? bytes? . -> . any)] diff --git a/collects/web-server/servlet-helpers.ss b/collects/web-server/servlet-helpers.ss index 44ae561d88..5588ef7efc 100644 --- a/collects/web-server/servlet-helpers.ss +++ b/collects/web-server/servlet-helpers.ss @@ -1,11 +1,11 @@ (module servlet-helpers mzscheme (require (lib "list.ss") (lib "etc.ss") - "util.ss" - "response.ss" - "request-parsing.ss" (lib "xml.ss" "xml") (lib "base64.ss" "net")) + (require "util.ss" + "response.ss" + "request-parsing.ss") (provide extract-binding/single extract-bindings @@ -18,15 +18,13 @@ permanently temporarily see-other - (all-from-except "request-parsing.ss" request-bindings) - (rename request-bindings request-bindings/raw) + (all-from "request-parsing.ss") (rename get-parsed-bindings request-bindings) - translate-escapes - ) + translate-escapes) ;; get-parsed-bindings : request -> (listof (cons sym str)) (define (get-parsed-bindings r) - (let ([x (request-bindings r)]) + (let ([x (request-bindings/raw r)]) (if (list? x) x (parse-bindings x)))) diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index d419352407..c36515ab9d 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -1,7 +1,6 @@ ;; Default choice for writing module servlets (module servlet mzscheme (require (lib "contract.ss") - (all-except "request-parsing.ss" request-bindings) "servlet-tables.ss" "response.ss" "servlet-helpers.ss" diff --git a/collects/web-server/timer-structs.ss b/collects/web-server/timer-structs.ss new file mode 100644 index 0000000000..1e6b020f3b --- /dev/null +++ b/collects/web-server/timer-structs.ss @@ -0,0 +1,6 @@ +(module timer-structs mzscheme + (require (lib "contract.ss")) + + (define-struct timer (expire-seconds)) + (provide/contract + [struct timer ([expire-seconds number?])])) \ No newline at end of file diff --git a/collects/web-server/timer.ss b/collects/web-server/timer.ss index 0affdc7752..0818f1f1fb 100644 --- a/collects/web-server/timer.ss +++ b/collects/web-server/timer.ss @@ -1,11 +1,10 @@ (module timer mzscheme + (require "timer-structs.ss") (provide timer? start-timer reset-timer increment-timer) ; BUG: reducing the timeout is ineffective ; efficiency: too many threads - (define-struct timer (expire-seconds)) - ; start-timer : num (-> void) -> timer ; to make a timer that calls to-do after msec from make-timer's application (define (start-timer sec to-do) diff --git a/collects/web-server/util.ss b/collects/web-server/util.ss index 0f84ec7bff..b9a694f368 100644 --- a/collects/web-server/util.ss +++ b/collects/web-server/util.ss @@ -4,14 +4,18 @@ (lib "list.ss") (lib "url.ss" "net") (lib "errortrace-lib.ss" "errortrace")) + (require "response-structs.ss" + "request-structs.ss") (provide provide-define-struct extract-flag translate-escapes hash-table-empty? - network-error) + url-path->string) (provide/contract + [decompose-request ((request?) . ->* . (url? symbol? string?))] + [network-error ((symbol? string?) (listof any/c) . ->* . (void))] [path->list (path? . -> . (cons/c (union path? (symbols 'up 'same)) (listof (union path? (symbols 'up 'same)))))] [url-path->path ((union (symbols 'up 'same) path?) string? . -> . path?)] @@ -21,6 +25,30 @@ [get-mime-type (path? . -> . bytes?)] [build-path-unless-absolute (path? (union string? path?) . -> . path?)]) + ;; ripped this off from url-unit.ss + (define (url-path->string strs) + (apply + string-append + (let loop ([strs strs]) + (cond + [(null? strs) (list)] + [else (list* "/" + (maybe-join-params (car strs)) + (loop (cdr strs)))])))) + + ;; needs to unquote things! + (define (maybe-join-params s) + (cond + [(string? s) s] + [else (path/param-path s)])) + + ;; decompse-request : request -> uri * symbol * string + (define (decompose-request req) + (let* ([uri (request-uri req)] + [method (request-method req)] + [path (translate-escapes (url-path->string (url-path uri)))]) + (values uri method path))) + ;; network-error: symbol string . values -> void ;; throws a formatted exn:fail:network (define (network-error src fmt . args) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index a26704f3cf..05d7bb0d5e 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -1,13 +1,13 @@ (module web-server-unit mzscheme (require "sig.ss" "connection-manager.ss" - (all-except "request-parsing.ss" request-bindings) "configuration-structures.ss" "util.ss" "response.ss" "servlet-tables.ss" "servlet.ss" "timer.ss") + (require (prefix passwords: "dispatch-passwords.ss")) (require (lib "tcp-sig.ss" "net") (lib "unitsig.ss") (lib "string.ss") @@ -150,21 +150,24 @@ [(connection-close? conn) (kill-connection! conn)] [else (connection-loop)]))))) - ;; dispatch: connection request host -> void + ;; dispatch : connection request host -> void + ;; NOTE: (Jay) First step towards a different way of doing dispatching. Initially, + ;; the dispatchers will be hard-coded based on the configuration file. + ;; Eventually, they will be more configurable and extensible. + (define (dispatch conn req host-info) + ((passwords:gen-dispatcher + host-info config:access + (lambda (conn req) + (dispatch-old conn req host-info))) + conn req)) + + ;; dispatch-old: connection request host -> void ;; NOTE: (GregP) I'm going to use the dispatch logic out of v208 for now. ;; I will move the other dispatch logic out of the prototype ;; at a later time. - (define (dispatch conn req host-info) - (let* ([uri (request-uri req)] - [method (request-method req)] - [path (translate-escapes (url-path->string (url-path uri)))]) + (define (dispatch-old conn req host-info) + (let-values ([(uri method path) (decompose-request req)]) (cond - [(access-denied? method path (request-headers req) host-info - config:access) - => (lambda (realm) - (adjust-connection-timeout! conn (timeouts-password - (host-timeouts host-info))) - (request-authentication conn method uri host-info realm))] [(conf-prefix? path) (cond [(string=? "/conf/refresh-servlets" path) @@ -180,7 +183,7 @@ [(string=? "/conf/refresh-passwords" path) ;; more here - send a nice error page (hash-table-put! config:access host-info - (read-passwords host-info)) + (passwords:read-passwords host-info)) (output-response/method conn ((responders-passwords-refreshed (host-responders host-info))) @@ -214,116 +217,7 @@ (define servlet-bin? (let ([svt-bin-re (regexp "^/servlets/.*")]) (lambda (str) - (regexp-match svt-bin-re str)))) - - ;; ripped this off from url-unit.ss - (define (url-path->string strs) - (apply - string-append - (let loop ([strs strs]) - (cond - [(null? strs) '()] - [else (list* "/" - (maybe-join-params (car strs)) - (loop (cdr strs)))])))) - - ;; needs to unquote things! - (define (maybe-join-params s) - (cond - [(string? s) s] - [else (path/param-path s)])) - - ;; **************************************** - ;; **************************************** - ;; ACCESS CONTROL - - ;; pass-entry = (make-pass-entry str regexp (list sym str)) - (define-struct pass-entry (domain pattern users)) - - ;; access-denied? : Method string x-table host Access-table -> (+ false str) - ;; the return string is the prompt for authentication - (define (access-denied? method uri-str headers host-info access-table) - ;; denied?: str sym str -> (U str #f) - ;; a function to authenticate the user - (let ([denied? - - ;; GregP lookup the authenticator function, if you can't find it, then try to load the - ;; passwords file for this host. - (hash-table-get - access-table host-info - (lambda () - ; more here - a malformed password file will kill the connection - (let ([f (read-passwords host-info)]) - (hash-table-put! access-table host-info f) - f)))]) - (let ([user-pass (extract-user-pass headers)]) - (if user-pass - (denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass)) - (denied? uri-str fake-user ""))))) - - (define-struct (exn:password-file exn) ()) - - ;; : host -> (str sym str -> (U str #f)) - ;; to produce a function that checks if a given url path is accessible by a given user with a given - ;; password. If not, the produced function returns a string, prompting for the password. - ;; If the password file does not exist, all accesses are allowed. If the file is malformed, an - ;; exn:password-file is raised. - (define (read-passwords host-info) - (let ([password-path (host-passwords host-info)]) - (with-handlers ([void (lambda (exn) - (raise (make-exn:password-file (format "could not load password file ~a" password-path) - (current-continuation-marks))))]) - (if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path))) - (let ([passwords - (let ([raw (load password-path)]) - (unless (password-list? raw) - (raise "malformed passwords")) - (map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x))) - raw))]) - - ;; string symbol bytes -> (union #f string) - (lambda (request-path user-name password) - (ormap (lambda (x) - (and (regexp-match (pass-entry-pattern x) request-path) - (let ([name-pass (assq user-name (pass-entry-users x))]) - (if (and name-pass - (string=? - (cadr name-pass) - (bytes->string/utf-8 password))) - #f - (pass-entry-domain x))))) - passwords))) - (lambda (req user pass) #f))))) - - (define fake-user (gensym)) - - ;; password-list? : TST -> bool - - ;; Note: andmap fails for dotted pairs at end. - ;; This is okay, since #f ends up raising a caught exception anyway. - (define (password-list? passwords) - (and (list? passwords) - (andmap (lambda (domain) - (and (pair? domain) (pair? (cdr domain)) (list (cddr domain)) - (string? (car domain)) - (string? (cadr domain)) - (andmap (lambda (x) - (and (pair? x) (pair? (cdr x)) (null? (cddr x)) - (symbol? (car x)) (string? (cadr x)))) - (cddr domain)))) - passwords))) - - ;; request-authentication : connection Method URL iport oport host str bool -> bool - ;; GregP: at first look, it seems that this gets called when the user - ;; has supplied bad authentication credentials. - (define (request-authentication conn method uri host-info realm) - (output-response/method - conn - ((responders-authentication (host-responders host-info)) - uri `(WWW-Authenticate . ,(string-append " Basic - realm=\"" realm "\""))) - method)) - + (regexp-match svt-bin-re str)))) ;; ************************************************************ ;; ************************************************************ @@ -413,7 +307,7 @@ '() (list "ignored")) meth) (let ([uri (request-uri req)]) - (set-request-bindings! + (set-request-bindings/raw! req (read-bindings/handled conn meth uri (request-headers req) host-info))