From 07474ad477b028e42e5d10ac1e321058afe0b4b5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 5 Nov 2008 19:00:07 +0000 Subject: [PATCH] Refactoring dispatch-passwords svn: r12242 --- .../dispatchers/dispatch-passwords-test.ss | 57 +++++++----- .../htdocs/servlets/examples/wc-fake.ss | 2 +- .../htdocs/servlets/examples/wc.ss | 2 +- .../dispatchers/dispatch-passwords.ss | 93 ++++++++++--------- .../web-server/scribblings/dispatchers.scrbl | 42 ++++++--- collects/web-server/web-server-unit.ss | 8 +- 6 files changed, 122 insertions(+), 82 deletions(-) diff --git a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss index 2e703d7154..597f7d0e50 100644 --- a/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-passwords-test.ss @@ -26,11 +26,21 @@ (write-test-passwords!) +(define (compat #:password-file pf + #:authentication-responder ar) + (let-values ([(update-password-cache! password-check) + (passwords:password-file->authorized? pf)]) + (values update-password-cache! + (passwords:make + (passwords:make-basic-denied?/path + password-check) + #:authentication-responder ar)))) + (define (runt applies? authorized?) (let/ec esc - (define-values (_ d) (passwords:make #:password-file test-passwords - #:authentication-responder - (lambda (u h) (esc h)))) + (define-values (_ d) (compat #:password-file test-passwords + #:authentication-responder + (lambda (u h) (esc h)))) (define-values (c i o) (make-mock-connection #"")) (d c (make-request 'get (if applies? @@ -45,25 +55,28 @@ (test-suite "Passwords" - (test-not-false - "Distribution file parses" - (read-passwords default-passwords)) - - (test-exn "authorized" - exn:dispatcher? - (lambda () (runt #t #t))) - (test-equal? "not authorized" - (let ([v (runt #t #f)]) - (list (header-field v) (header-value v))) - (list #"WWW-Authenticate" #" Basic realm=\"secret stuff\"")) - (test-exn "does not apply" - exn:dispatcher? - (lambda () - (runt #f #f))) - (test-exn "does not apply (authd)" - exn:dispatcher? - (lambda () - (runt #f #t))) + (test-suite + "Default configuration" + + (test-not-false + "Distribution file parses" + (read-passwords default-passwords)) + + (test-exn "authorized" + exn:dispatcher? + (lambda () (runt #t #t))) + (test-equal? "not authorized" + (let ([v (runt #t #f)]) + (list (header-field v) (header-value v))) + (list #"WWW-Authenticate" #" Basic realm=\"secret stuff\"")) + (test-exn "does not apply" + exn:dispatcher? + (lambda () + (runt #f #f))) + (test-exn "does not apply (authd)" + exn:dispatcher? + (lambda () + (runt #f #t)))) ; XXX test refresh cache diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/wc-fake.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/wc-fake.ss index af6b1ae131..756df893eb 100644 --- a/collects/web-server/default-web-root/htdocs/servlets/examples/wc-fake.ss +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/wc-fake.ss @@ -19,7 +19,7 @@ (div (h3 "Second") ,(inc2 next-counter2 next-counter1)))))))) (define (include-counter my-counter other-counter embed/url) - ; XXX This shouldn't be necessary (but is for testing, not in production) + ; Note: This shouldn't be necessary (but is for testing, not in production) (call-with-current-continuation (lambda (k) (letrec ([include diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/wc.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/wc.ss index 485e192785..b7e27cb562 100644 --- a/collects/web-server/default-web-root/htdocs/servlets/examples/wc.ss +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/wc.ss @@ -26,7 +26,7 @@ (make-web-cell 0)) (define (include-counter a-counter) - ; XXX This shouldn't be necessary (but is for testing, not in production) + ; Note: This shouldn't be necessary (but is for testing, not in production) (call-with-current-continuation (lambda (k) (define (generate) diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 33b02146cb..81812954b1 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -9,22 +9,56 @@ "../private/response-structs.ss" "../servlet/basic-auth.ss" "../private/response.ss") + +(define denied?/c (request? . -> . (or/c false/c string?))) +(define authorized?/c (string? (or/c false/c bytes?) (or/c false/c bytes?) . -> . (or/c false/c string?))) + (provide/contract [interface-version dispatcher-interface-version/c] - [make (->* () - (#:password-file path-string? - #:authentication-responder - (url? header? . -> . response?)) - (values - (-> void) - dispatcher/c))]) + [denied?/c contract?] + [make (->* (denied?/c) + (#:authentication-responder + (url? header? . -> . response?)) + dispatcher/c)] + [authorized?/c contract?] + [make-basic-denied?/path + (authorized?/c . -> . denied?/c)] + [password-file->authorized? + (path? . -> . (values (-> void) + authorized?/c))]) (define interface-version 'v1) -(define (make ; XXX Take authorized? function - #:password-file [password-file "passwords"] - #:authentication-responder - [authentication-responder - (gen-authentication-responder "forbidden.html")]) +(define (make denied? + #:authentication-responder + [authentication-responder + (gen-authentication-responder "forbidden.html")]) + (lambda (conn req) + (define uri (request-uri req)) + (define method (request-method req)) + (cond + [(denied? req) + => (lambda (realm) + (request-authentication conn method uri + authentication-responder + realm))] + [else + (next-dispatcher)]))) + +(define (make-basic-denied?/path + authorized?) + (lambda (req) + (define uri (request-uri req)) + (define path (url-path->string (url-path uri))) + (cond + [(extract-user-pass (request-headers/raw req)) + => (lambda (user*pass) + (authorized? path + (car user*pass) + (cdr user*pass)))] + [else + (authorized? path #f #f)]))) + +(define (password-file->authorized? password-file) (define last-read-time (box #f)) (define password-cache (box #f)) (define (update-password-cache!) @@ -38,39 +72,14 @@ (define (read-password-cache) (update-password-cache!) (unbox password-cache)) - (define (dispatch conn req) - (define uri (request-uri req)) - (define path (url-path->string (url-path uri))) - (define method (request-method req)) - (define denied? (read-password-cache)) - (cond - [(and denied? - (access-denied? method path (request-headers/raw req) denied?)) - => (lambda (realm) - (request-authentication conn method uri - authentication-responder - realm))] - [else - (next-dispatcher)])) (values update-password-cache! - dispatch)) - -;; **************************************** -;; **************************************** -;; ACCESS CONTROL - + (lambda (path user pass) + (define denied? (read-password-cache)) + (denied? path (if user (lowercase-symbol! user) #f) pass)))) + ;; pass-entry = (make-pass-entry str regexp (list sym str)) (define-struct pass-entry (domain pattern users)) -;; access-denied? : Method string x-table denied? -> (or/c false str) -;; denied?: str sym str -> (or/c str #f) -;; the return string is the prompt for authentication -(define (access-denied? method uri-str headers denied?) - (define 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 -> (or/c str #f)) @@ -106,8 +115,6 @@ (pass-entry-domain x))))) passwords))))) -(define fake-user (gensym)) - ;; password-list? : TST -> bool ;; Note: andmap fails for dotted pairs at end. diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index dc8451dfb7..3ef9333835 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -247,24 +247,42 @@ a URL that refreshes the password file, servlet cache, etc.} @elem{defines a dispatcher constructor that performs HTTP Basic authentication filtering.}]{ -@defproc[(make [#:password-file password-file path-string? "passwords"] +@(require (for-label web-server/private/request-structs + web-server/private/response-structs + net/url + web-server/configuration/responders)) + +@defthing[denied?/c contract?]{ + Equivalent to @scheme[(request? . -> . (or/c false/c string?))]. + The return is the authentication realm as a string if the request is not authorized and + @scheme[#f] if the request @emph{is} authorized. +} + +@defproc[(make [denied? denied?/c] [#:authentication-responder authentication-responder - ((url url?) (header header?) . -> . response?) + (url? header? . -> . response?) (gen-authentication-responder "forbidden.html")]) - (values (-> void) - dispatcher/c)]{ - The first returned value is a procedure that refreshes the password - file used by the dispatcher. - - The dispatcher that is returned does the following: - Checks if the request contains Basic authentication credentials, and that - they are included in @scheme[password-file]. If they are not, + dispatcher/c]{ + A dispatcher that checks if the request is denied based on @scheme[denied?]. If so, then @scheme[authentication-responder] is called with a @scheme[header] that - requests credentials. If they are, then @scheme[next-dispatcher] is + requests credentials. If not, then @scheme[next-dispatcher] is invoked. +} + +@defthing[authorized?/c contract?]{ + Equivalent to @scheme[(string? (or/c false/c bytes?) (or/c false/c bytes?) . -> . (or/c false/c string?))]. + The input is the URI as a string and the username and passwords as bytes. + The return is the authentication realm as a string if the user is not authorized and + @scheme[#f] if the request @emph{is} authorized. +} + +@defproc[(make-basic-denied?/path [password-file path-string?]) + (values (-> void) + authorized?/c)]{ + Creates an authorization procedure based on the given password file. The first returned value + is a procedure that refreshes the password cache used by the authorization procedure. - @; XXX Separate out password-file work @scheme[password-file] is parsed as: @schemeblock[(list ([domain : string?] [path : string-regexp?] diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index b1f56c7408..714031dc23 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -58,11 +58,13 @@ #:log-path (host-log-path host-info)) (lambda (conn req) (next-dispatcher))) (let-values ([(update-password-cache! password-check) - (passwords:make #:password-file (host-passwords host-info) - #:authentication-responder (responders-authentication (host-responders host-info)))]) + (passwords:password-file->authorized? (host-passwords host-info))]) (sequencer:make (timeout:make (timeouts-password (host-timeouts host-info))) - password-check + (passwords:make + (passwords:make-basic-denied?/path + password-check) + #:authentication-responder (responders-authentication (host-responders host-info))) (path-procedure:make "/conf/refresh-passwords" (lambda _ (update-password-cache!)