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

Refactoring dispatcher and structs

Browse Source 
svn: r677
This commit is contained in:
Jay McCarthy 2005-08-25 19:51:28 +00:00
parent 97f7ef11b9
commit c88a732bda
14 changed files with 295 additions and 229 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/web-server/connection-manager.ss
View File

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

12
collects/web-server/connection-structs.ss Normal file
View File

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

114
collects/web-server/dispatch-passwords.ss Normal file
View File

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

9
collects/web-server/dispatch.ss Normal file
View File

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

22
collects/web-server/request-parsing.ss
View File

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

25
collects/web-server/request-structs.ss Normal file
View File

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

67
collects/web-server/response-structs.ss Normal file
View File

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

66
collects/web-server/response.ss
View File

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

14
collects/web-server/servlet-helpers.ss
View File

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

1
collects/web-server/servlet.ss
View File

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

6
collects/web-server/timer-structs.ss Normal file
View File

@ -0,0 +1,6 @@
(module timer-structs mzscheme
(require (lib "contract.ss"))
(define-struct timer (expire-seconds))
(provide/contract
[struct timer ([expire-seconds number?])]))

3
collects/web-server/timer.ss
View File

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

30
collects/web-server/util.ss
View File

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

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

@ -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)))
@ -216,115 +219,6 @@
(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))
;; ************************************************************
;; ************************************************************
;; SERVING FILES
@ -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))