suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactoring dispatch-passwords

Browse Source 
svn: r12242
This commit is contained in:
Jay McCarthy 2008-11-05 19:00:07 +00:00
parent 9283c96bfd
commit 07474ad477
6 changed files with 122 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
collects/tests/web-server/dispatchers/dispatch-passwords-test.ss
View File

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

2
collects/web-server/default-web-root/htdocs/servlets/examples/wc-fake.ss
View File

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

2
collects/web-server/default-web-root/htdocs/servlets/examples/wc.ss
View File

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

93
collects/web-server/dispatchers/dispatch-passwords.ss
View File

@ -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.

42
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -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?]

8
collects/web-server/web-server-unit.ss
View File

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