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

bug

Browse Source 
svn: r4535
This commit is contained in:
Jay McCarthy 2006-10-09 20:09:29 +00:00
parent e98caf31c1
commit 37a25a74df
1 changed files with 31 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -23,20 +23,23 @@
(define last-read-time (box #f))
(define password-cache (box #f))
(define (update-password-cache!)
(define cur-mtime (file-or-directory-modify-seconds password-file))
(when (or (not (unbox last-read-time))
(cur-mtime . > . (unbox last-read-time))
(not (unbox password-cache)))
(set-box! last-read-time cur-mtime)
; more here - a malformed password file will kill the connection
(set-box! password-cache (read-passwords password-file))))
(when (and (file-exists? password-file) (memq 'read (file-or-directory-permissions password-file)))
(let ([cur-mtime (file-or-directory-modify-seconds password-file)])
(when (or (not (unbox last-read-time))
(cur-mtime . > . (unbox last-read-time))
(not (unbox password-cache)))
(set-box! last-read-time cur-mtime)
; more here - a malformed password file will kill the connection
(set-box! password-cache (read-passwords password-file))))))
(define (read-password-cache)
(update-password-cache!)
(unbox password-cache))
(lambda (conn req)
(define-values (uri method path) (decompose-request req))
(define denied? (read-password-cache))
(cond
[(access-denied? method path (request-headers/raw req) (read-password-cache))
[(and denied?
(access-denied? method path (request-headers/raw req) denied?))
=> (lambda (realm)
(adjust-connection-timeout! conn password-connection-timeout)
(request-authentication conn method uri
@ -62,7 +65,7 @@
;; 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 (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))
@ -80,27 +83,25 @@
(raise (make-exn:password-file (string->immutable-string
(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 -> (or/c #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))))
(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 -> (or/c #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)))))
(define fake-user (gensym))