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

pr 8028 and 8029

Browse Source 
svn: r3347
This commit is contained in:
Jay McCarthy 2006-06-13 14:48:34 +00:00
parent 7015529bf5
commit fa67303a75
14 changed files with 328 additions and 275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/web-server/bindings.ss Normal file
View File

@ -0,0 +1,27 @@
(module bindings mzscheme
(require (lib "list.ss"))
(provide extract-binding/single
extract-bindings
exists-binding?)
; extract-binding/single : sym (listof (cons str str)) -> str
(define (extract-binding/single name bindings)
(define lst (extract-bindings name bindings))
(cond
[(empty? lst)
(error 'extract-binding/single "~e not found in ~e" name bindings)]
[(empty? (rest lst))
(first lst)]
[else
(error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)]))
; extract-bindings : sym (listof (cons str str)) -> (listof str)
(define (extract-bindings name bindings)
(map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
; exists-binding? : sym (listof (cons sym str)) -> bool
; for checkboxes
(define (exists-binding? name bindings)
(if (assq name bindings)
#t
#f)))

11
collects/web-server/configuration.ss
View File

@ -21,6 +21,17 @@
[load-configuration (path? . -> . unit/sig?)]
[load-developer-configuration (path? . -> . unit/sig?)])
(provide error-response
servlet-loading-responder
gen-servlet-not-found
gen-servlet-responder
gen-servlets-refreshed
gen-passwords-refreshed
gen-authentication-responder
gen-protocol-responder
gen-file-not-found-responder
gen-collect-garbage-responder)
(define default-configuration-table-path
(build-path (collection-path "web-server") "configuration-table"))

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

@ -32,7 +32,7 @@
;; kill-connection!: connection -> void
;; kill this connection
(define (kill-connection! conn-demned)
(define (kill-connection! conn-demned)
(cancel-timer! (connection-timer conn-demned))
(with-handlers ([exn:fail:network? void])
(close-output-port (connection-o-port conn-demned)))

70
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -1,46 +1,54 @@
(module dispatch-files mzscheme
(require (lib "url.ss" "net")
(lib "xml.ss" "xml")
(lib "kw.ss")
(lib "list.ss"))
(require "dispatch.ss"
"../configuration.ss"
"../util.ss"
"../mime-types.ss"
"../response.ss")
(provide interface-version
gen-dispatcher)
make)
(define interface-version 'v1)
(define (gen-dispatcher htdocs-path mime-types-path indices file-not-found-responder)
(let ([get-mime-type (make-get-mime-type mime-types-path)])
(define/kw (make #:key
[htdocs-path "htdocs"]
[mime-types-path "mime.types"]
[indices (list "index.html" "index.htm")]
[file-not-found-responder
(gen-file-not-found-responder "not-found.html")])
(define get-mime-type (make-get-mime-type mime-types-path))
(lambda (conn req)
(let-values ([(uri method path) (decompose-request req)])
;; ************************************************************
;; ************************************************************
;; SERVING FILES
;; serve-file : connection symbol uri host -> void
;; to find the file, including searching for implicit index files, and serve it out
(let ([path (url-path->path htdocs-path
(translate-escapes (url-path->string (url-path uri))))])
(cond
[(file-exists? path)
(output-file conn path method (get-mime-type path))]
[(directory-exists? path)
(let loop ([dir-defaults indices])
(cond
[(pair? dir-defaults)
(let ([full-name (build-path path (first dir-defaults))])
(if (file-exists? full-name)
(cond
[(looks-like-directory? (url-path->string (url-path uri)))
(output-file conn full-name method (get-mime-type full-name))]
[else
(output-slash-message conn method (url-path->string (url-path uri)))])
(loop (rest dir-defaults))))]
[else
(output-response/method conn (file-not-found-responder uri) method)]))]
[else
(output-response/method conn (file-not-found-responder uri) method)]))))))
(define-values (uri method _path) (decompose-request req))
;; ************************************************************
;; ************************************************************
;; SERVING FILES
;; serve-file : connection symbol uri host -> void
;; to find the file, including searching for implicit index files, and serve it out
(define path
(url-path->path htdocs-path
(translate-escapes (url-path->string (url-path uri)))))
(cond
[(file-exists? path)
(output-file conn path method (get-mime-type path))]
[(directory-exists? path)
(let loop ([dir-defaults indices])
(cond
[(pair? dir-defaults)
(let ([full-name (build-path path (first dir-defaults))])
(if (file-exists? full-name)
(cond
[(looks-like-directory? (url-path->string (url-path uri)))
(output-file conn full-name method (get-mime-type full-name))]
[else
(output-slash-message conn method (url-path->string (url-path uri)))])
(loop (rest dir-defaults))))]
[else
(output-response/method conn (file-not-found-responder uri) method)]))]
[else
(output-response/method conn (file-not-found-responder uri) method)])))
;; looks-like-directory : str -> bool
;; to determine if is url style path looks like it refers to a directory

4
collects/web-server/dispatchers/dispatch-host.ss
View File

@ -2,10 +2,10 @@
(require "dispatch.ss"
"../servlet-helpers.ss")
(provide interface-version
gen-dispatcher)
make)
(define interface-version 'v1)
(define (gen-dispatcher lookup-dispatcher)
(define (make lookup-dispatcher)
(lambda (conn req)
(let* ([host (get-host (request-uri req) (request-headers/raw req))])
((lookup-dispatcher host) conn req)))))

63
collects/web-server/dispatchers/dispatch-log.ss
View File

@ -1,15 +1,18 @@
(module dispatch-log mzscheme
(require (lib "url.ss" "net")
(lib "date.ss")
(lib "kw.ss")
(lib "async-channel.ss")
(lib "plt-match.ss"))
(require "dispatch.ss"
"../servlet-helpers.ss")
(provide interface-version
gen-dispatcher)
make)
(define interface-version 'v1)
(define (gen-dispatcher log-format log-path)
(define/kw (make #:key
[log-format 'parenthesized-default]
[log-path #f])
(if log-path
(case log-format
[(parenthesized-default)
@ -34,31 +37,31 @@
; to produce a string that is displayed into the log file
; This is a kill-safe wait-less abstraction
(define (gen-log-message log-format log-path)
(let* ([log-ch (make-async-channel)]
[log-thread
(thread/suspend-to-kill
(lambda ()
(let loop ([log-p #f])
(with-handlers ([exn? (lambda (e) (loop #f))])
(if (not (and log-p (file-exists? log-path)))
(begin
(unless (eq? log-p #f)
(close-output-port log-p))
(let ([new-log-p (open-output-file log-path 'append)])
(file-stream-buffer-mode new-log-p 'line)
(loop new-log-p)))
(sync
(handle-evt
log-ch
(match-lambda
[(list host-ip client-ip method uri host)
(display
(format "~s~n"
(list 'from client-ip 'to host-ip 'for (url->string uri) 'at
(date->string (seconds->date (current-seconds)) #t)))
log-p)
(loop log-p)]))))))))])
(lambda args
(thread-resume log-thread)
(async-channel-put log-ch args)
(void)))))
(define log-ch (make-async-channel))
(define log-thread
(thread/suspend-to-kill
(lambda ()
(let loop ([log-p #f])
(with-handlers ([exn? (lambda (e) (loop #f))])
(if (not (and log-p (file-exists? log-path)))
(begin
(unless (eq? log-p #f)
(close-output-port log-p))
(let ([new-log-p (open-output-file log-path 'append)])
(file-stream-buffer-mode new-log-p 'line)
(loop new-log-p)))
(sync
(handle-evt
log-ch
(match-lambda
[(list host-ip client-ip method uri host)
(display
(format "~s~n"
(list 'from client-ip 'to host-ip 'for (url->string uri) 'at
(date->string (seconds->date (current-seconds)) #t)))
log-p)
(loop log-p)])))))))))
(lambda args
(thread-resume log-thread (current-custodian))
(async-channel-put log-ch args)
(void))))

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

@ -1,42 +1,47 @@
(module dispatch-passwords mzscheme
(require (lib "kw.ss"))
(require "dispatch.ss"
(all-except "../util.ss" translate-escapes)
"../configuration.ss"
"../servlet-helpers.ss"
"../connection-manager.ss"
"../response.ss")
"../response.ss")
(provide interface-version
gen-dispatcher)
make)
(define interface-version 'v1)
(define (gen-dispatcher password-file password-connection-timeout authentication-responder passwords-refresh-responder)
(let* ([password-cache (box #f)]
[reset-password-cache!
(lambda ()
; more here - a malformed password file will kill the connection
(set-box! password-cache (read-passwords password-file)))]
[read-password-cache
(lambda ()
(unbox password-cache))])
(reset-password-cache!)
(lambda (conn req)
(let-values ([(uri method path) (decompose-request req)])
(cond
[(access-denied? method path (request-headers/raw req) (read-password-cache))
=> (lambda (realm)
(adjust-connection-timeout! conn password-connection-timeout)
(request-authentication conn method uri
authentication-responder
realm))]
[(string=? "/conf/refresh-passwords" path)
;; more here - send a nice error page
(reset-password-cache!)
(output-response/method
conn
(passwords-refresh-responder)
method)]
[else
(next-dispatcher)])))))
(define/kw (make #:key
[password-file "passwords"]
[password-connection-timeout 300]
[authentication-responder
(gen-authentication-responder "forbidden.html")]
[passwords-refresh-responder
(gen-passwords-refreshed "passwords-refresh.html")])
(define password-cache (box #f))
(define (reset-password-cache!)
; more here - a malformed password file will kill the connection
(set-box! password-cache (read-passwords password-file)))
(define (read-password-cache)
(unbox password-cache))
(reset-password-cache!)
(lambda (conn req)
(define-values (uri method path) (decompose-request req))
(cond
[(access-denied? method path (request-headers/raw req) (read-password-cache))
=> (lambda (realm)
(adjust-connection-timeout! conn password-connection-timeout)
(request-authentication conn method uri
authentication-responder
realm))]
[(string=? "/conf/refresh-passwords" path)
;; more here - send a nice error page
(reset-password-cache!)
(output-response/method
conn
(passwords-refresh-responder)
method)]
[else
(next-dispatcher)])))
;; ****************************************
;; ****************************************
@ -49,10 +54,10 @@
;; denied?: str sym str -> (or/c str #f)
;; the return string is the prompt for authentication
(define (access-denied? method uri-str headers denied?)
(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 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) ())

4
collects/web-server/dispatchers/dispatch-pathprocedure.ss
View File

@ -3,10 +3,10 @@
"../util.ss"
"../response.ss")
(provide interface-version
gen-dispatcher)
make)
(define interface-version 'v1)
(define ((gen-dispatcher the-path procedure) conn req)
(define ((make the-path procedure) conn req)
(let-values ([(uri method path) (decompose-request req)])
(if (string=? the-path path)
(output-response/method

4
collects/web-server/dispatchers/dispatch-sequencer.ss
View File

@ -2,10 +2,10 @@
(require (lib "list.ss"))
(require "dispatch.ss")
(provide interface-version
gen-dispatcher)
make)
(define interface-version 'v1)
(define ((gen-dispatcher . dispatchers) conn req)
(define ((make . dispatchers) conn req)
(let loop ([dispatchers dispatchers])
(let ([c (first dispatchers)])
(with-handlers ([exn:dispatcher?

48
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -1,5 +1,6 @@
(module dispatch-servlets mzscheme
(require (lib "url.ss" "net")
(lib "kw.ss")
(lib "plt-match.ss")
(lib "unitsig.ss"))
(require "dispatch.ss"
@ -8,6 +9,7 @@
"../response.ss"
"../servlet.ss"
"../sig.ss"
"../configuration.ss"
(all-except "../util.ss" translate-escapes)
"../managers/manager.ss"
"../managers/timeouts.ss"
@ -15,14 +17,22 @@
"../private/servlet.ss"
"../private/cache-table.ss")
(provide interface-version
gen-dispatcher)
make)
(define interface-version 'v1)
(define (gen-dispatcher config:instances config:scripts config:make-servlet-namespace
servlet-root
responders-servlets-refreshed responders-servlet-loading responders-servlet
responders-file-not-found
timeouts-servlet-connection timeouts-default-servlet)
(define/kw (make config:instances config:scripts config:make-servlet-namespace
#:key
[servlet-root "servlets"]
[responders-servlets-refreshed
(gen-servlets-refreshed "servlet-refresh.html")]
[responders-servlet-loading
servlet-loading-responder]
[responders-servlet
(gen-servlet-responder "servlet-error.html")]
[responders-file-not-found
(gen-file-not-found-responder "not-found.html")]
[timeouts-servlet-connection (* 60 60 24)]
[timeouts-default-servlet 30])
;; ************************************************************
;; ************************************************************
;; SERVING SERVLETS
@ -47,7 +57,7 @@
(invoke-servlet-continuation conn req instance-id k-id salt)])]
[else
(servlet-content-producer/path conn req uri)])]))
;; servlet-content-producer/path: connection request url -> void
;; This is not a continuation url so the loading behavior is determined
;; by the url path. Build the servlet path and then load the servlet
@ -279,9 +289,9 @@
(make-servlet (current-custodian)
(current-namespace)
(create-timeout-manager
default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
(v0.servlet->v1.lambda s))]
; FIX - reason about exceptions from dynamic require (catch and report if not already)
;; module servlet
@ -295,9 +305,9 @@
(make-servlet (current-custodian)
(current-namespace)
(create-timeout-manager
default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
(v1.module->v1.lambda timeout start)))]
[(v2-transitional) ; XXX: Undocumented
(let ([start (dynamic-require module-name 'start)]
@ -308,9 +318,9 @@
(define instance-expiration-handler
(dynamic-require module-name 'instance-expiration-handler))
(create-timeout-manager
instance-expiration-handler
timeouts-servlet-connection
timeout))])
instance-expiration-handler
timeouts-servlet-connection
timeout))])
(dynamic-require module-name 'manager))])
(make-servlet (current-custodian)
(current-namespace)
@ -323,9 +333,9 @@
(make-servlet (current-custodian)
(current-namespace)
(create-timeout-manager
default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
(v0.response->v1.lambda s a-path))]
[else
(error 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))

151
collects/web-server/parse-table.ss
View File

@ -1,82 +1,85 @@
(module parse-table mzscheme
(require (lib "match.ss")
"configuration-table-structs.ss")
(require (lib "list.ss"))
(require "configuration-table-structs.ss"
"bindings.ss")
(provide parse-configuration-table)
(define (get-binding key bindings default)
(first (get-binding* key bindings (list default))))
(define (get-binding* key bindings default)
(with-handlers ([exn? (lambda _ default)])
(extract-binding/single key bindings)))
; parse-configuration-table : tst -> configuration-table
(define parse-configuration-table
(match-lambda
[`((port ,port)
(max-waiting ,max-waiting)
(initial-connection-timeout ,initial-connection-timeout)
(default-host-table
,default-host-table)
(virtual-host-table . ,virtual-host-table))
(if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
; more here - list? isn't really picky enough
(list? virtual-host-table))
(make-configuration-table
port max-waiting initial-connection-timeout
(parse-host default-host-table)
(map (lambda (h)
(if (and (pair? h) (pair? (cdr h)) (null? (cddr h)))
(cons (car h) (parse-host (cadr h)))
(error 'parse-configuration-table "invalid virtual-host entry ~s" h)))
virtual-host-table))
(error 'parse-configuration-table "invalid configuration values ~s"
(list port max-waiting initial-connection-timeout default-host-table virtual-host-table)))]
[x (error 'parse-configuration-table "malformed configuration ~s" x)]))
(define (parse-configuration-table t)
(define port (get-binding 'port t 80))
(define max-waiting (get-binding 'max-waiting t 40))
(define initial-connection-timeout (get-binding 'initial-connection-timeout t 30))
(define default-host-table (get-binding* 'default-host-table t `()))
(define virtual-host-table (get-binding* 'virtual-host-table t `()))
(if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
; more here - list? isn't really picky enough
(list? virtual-host-table))
(make-configuration-table
port max-waiting initial-connection-timeout
(parse-host default-host-table)
(map (lambda (h)
(if (and (pair? h) (pair? (cdr h)) (null? (cddr h)))
(cons (car h) (parse-host (cadr h)))
(error 'parse-configuration-table "invalid virtual-host entry ~s" h)))
virtual-host-table))
(error 'parse-configuration-table "invalid configuration values ~s"
(list port max-waiting initial-connection-timeout default-host-table virtual-host-table))))
; parse-host : tst -> host-table
(define parse-host
(match-lambda
[`(host-table
(default-indices . ,default-indices)
(log-format ,log-format)
(messages
(servlet-message ,servlet-message)
(authentication-message ,authentication-message)
(servlets-refreshed ,servlets-refreshed)
(passwords-refreshed ,passwords-refreshed)
(file-not-found-message ,file-not-found-message)
(protocol-message ,protocol-message)
(collect-garbage ,collect-garbage))
(timeouts
(default-servlet-timeout ,default-servlet-timeout)
(password-connection-timeout ,password-connection-timeout)
(servlet-connection-timeout ,servlet-connection-timeout)
(file-per-byte-connection-timeout ,file-per-byte-connection-timeout)
(file-base-connection-timeout ,file-base-connection-timeout))
(paths
(configuration-root ,configuration-root)
(host-root ,host-root)
(log-file-path ,log-file-path)
(file-root ,file-root)
(servlet-root ,servlet-root)
(mime-types ,mime-types)
(password-authentication ,password-authentication)))
(make-host-table
default-indices log-format
(make-messages servlet-message
authentication-message
servlets-refreshed
passwords-refreshed
file-not-found-message
protocol-message
collect-garbage)
(make-timeouts default-servlet-timeout
password-connection-timeout
servlet-connection-timeout
file-per-byte-connection-timeout
file-base-connection-timeout)
(make-paths configuration-root
host-root
log-file-path
file-root
servlet-root
mime-types
password-authentication))]
[x (error 'parse-host "malformed host ~s" x)]))
(define (parse-host t)
(define host-table (get-binding* 'host-table t `()))
(define default-indices (get-binding* 'default-indices host-table `("index.html" "index.htm")))
(define log-format (get-binding 'log-format host-table 'parenthesized-default))
(define messages (get-binding* 'messages host-table `()))
(define servlet-message (get-binding 'servlet-message messages "servlet-error.html"))
(define authentication-message (get-binding 'authentication-message messages "forbidden.html"))
(define servlets-refreshed (get-binding 'servlets-refreshed messages "servlet-refresh.html"))
(define passwords-refreshed (get-binding 'passwords-refreshed messages "passwords-refresh.html"))
(define file-not-found-message (get-binding 'file-not-found-message messages "not-found.html"))
(define protocol-message (get-binding 'protocol-message messages "protocol-error.html"))
(define collect-garbage (get-binding 'collect-garbage messages "collect-garbage.html"))
(define timeouts (get-binding* 'timeouts host-table `()))
(define default-servlet-timeout (get-binding 'default-servlet-timeout timeouts 30))
(define password-connection-timeout (get-binding 'password-connection-timeout timeouts 300))
(define servlet-connection-timeout (get-binding 'servlet-connection-timeout timeouts (* 60 60 24)))
(define file-per-byte-connection-timeout (get-binding 'file-per-byte-connection-timeout timeouts 1/20))
(define file-base-connection-timeout (get-binding 'file-base-connection-timeout timeouts 30))
(define paths (get-binding* 'paths host-table `()))
(define configuration-root (get-binding 'configuration-root paths "conf"))
(define host-root (get-binding 'host-root paths "default-web-root"))
(define log-file-path (get-binding 'log-file-path paths "log"))
(define file-root (get-binding 'file-root paths "htdocs"))
(define servlet-root (get-binding 'servlet-root paths "."))
(define mime-types (get-binding 'mime-types paths "mime.types"))
(define password-authentication (get-binding 'password-authentication paths "passwords"))
(make-host-table
default-indices log-format
(make-messages servlet-message
authentication-message
servlets-refreshed
passwords-refreshed
file-not-found-message
protocol-message
collect-garbage)
(make-timeouts default-servlet-timeout
password-connection-timeout
servlet-connection-timeout
file-per-byte-connection-timeout
file-base-connection-timeout)
(make-paths configuration-root
host-root
log-file-path
file-root
servlet-root
mime-types
password-authentication)))
; nat? : tst -> bool
(define (nat? x)

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

@ -7,11 +7,10 @@
(lib "url.ss" "net"))
(require "util.ss"
"response.ss"
"request-structs.ss")
"request-structs.ss"
"bindings.ss")
(provide get-host
extract-binding/single
extract-bindings
exists-binding?
(all-from "bindings.ss")
extract-user-pass
build-suspender
make-html-response/incremental
@ -52,27 +51,7 @@
[(struct header (_ v))
(string->symbol (bytes->string/utf-8 v))])]
[else DEFAULT-HOST-NAME]))
; extract-binding/single : sym (listof (cons str str)) -> str
(define (extract-binding/single name bindings)
(let ([lst (extract-bindings name bindings)])
(cond
[(null? lst)
(error 'extract-binding/single "~e not found in ~e" name bindings)]
[(null? (cdr lst)) (car lst)]
[else (error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)])))
; extract-bindings : sym (listof (cons str str)) -> (listof str)
(define (extract-bindings name bindings)
(map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
; exists-binding? : sym (listof (cons sym str)) -> bool
; for checkboxes
(define (exists-binding? name bindings)
(if (assq name bindings)
#t
#f))
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
(define build-suspender
(opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])

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

@ -6,9 +6,9 @@
start-timer reset-timer! increment-timer!
cancel-timer!
start-timer-manager)
(define timer-ch (make-async-channel))
; start-timer-manager : custodian -> void
; The timer manager thread
(define (start-timer-manager server-custodian)
@ -35,42 +35,46 @@
(loop (remq timer timers)))))
timers))))))
(void))
;; Limitation on this add-timer: thunk cannot make timer
;; requests directly, because it's executed directly by
;; the timer-manager thread
;; add-timer : number (-> void) -> timer
(define (add-timer msecs thunk)
(let* ([now (current-inexact-milliseconds)]
[timer
(make-timer (alarm-evt (+ now msecs))
(+ now msecs)
thunk)])
(async-channel-put timer-ch
(lambda (timers)
(cons timer timers)))
timer))
(define now (current-inexact-milliseconds))
(define timer
(make-timer (alarm-evt (+ now msecs))
(+ now msecs)
thunk))
(async-channel-put
timer-ch
(lambda (timers)
(list* timer timers)))
timer)
; revise-timer! : timer msecs (-> void) -> timer
; revise the timer to ring msecs from now
(define (revise-timer! timer msecs thunk)
(let ([now (current-inexact-milliseconds)])
(async-channel-put
timer-ch
(lambda (timers)
(set-timer-evt! timer (alarm-evt (+ now msecs)))
(set-timer-expire-seconds! timer (+ now msecs))
(set-timer-action! timer thunk)
timers))))
(define now (current-inexact-milliseconds))
(async-channel-put
timer-ch
(lambda (timers)
(set-timer-evt! timer (alarm-evt (+ now msecs)))
(set-timer-expire-seconds! timer (+ now msecs))
(set-timer-action! timer thunk)
timers)))
(define (cancel-timer! timer)
(revise-timer! timer 0 void))
(async-channel-put
timer-ch
(lambda (timers)
(remq timer timers))))
; start-timer : num (-> void) -> timer
; to make a timer that calls to-do after sec from make-timer's application
(define (start-timer secs to-do)
(add-timer (* 1000 secs) to-do))
; reset-timer : timer num -> void
; to cause timer to expire after sec from the adjust-msec-to-live's application
(define (reset-timer! timer secs)

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

@ -17,7 +17,9 @@
(require (lib "tcp-sig.ss" "net")
(lib "unitsig.ss")
(lib "string.ss")
(lib "list.ss")
(lib "url.ss" "net"))
(provide web-server@)
;; ****************************************
@ -123,41 +125,42 @@
(define initial-connection-timeout config:initial-connection-timeout)
;; dispatch : connection request -> void
(define dispatch-cache (make-cache-table))
(define dispatch
(let ([cache (make-cache-table)])
(host:gen-dispatcher
(lambda (host)
(cache-table-lookup!
cache host
(lambda ()
(host:make
(lambda (host)
(cache-table-lookup!
dispatch-cache host
(lambda ()
(parameterize ([current-custodian (current-server-custodian)])
(host-info->dispatcher
(config:virtual-hosts (symbol->string host)))))))))
;; host-info->dispatcher : host-info -> conn request -> void
(define (host-info->dispatcher host-info)
(sequencer:gen-dispatcher
(log:gen-dispatcher (host-log-format host-info)
(host-log-path host-info))
(passwords:gen-dispatcher (host-passwords host-info)
(timeouts-password (host-timeouts host-info))
(responders-authentication (host-responders host-info))
(responders-passwords-refreshed (host-responders host-info)))
(path-procedure:gen-dispatcher "/conf/collect-garbage"
(lambda ()
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(servlets:gen-dispatcher config:instances config:scripts config:make-servlet-namespace
(paths-servlet (host-paths host-info))
(responders-servlets-refreshed (host-responders host-info))
(responders-servlet-loading (host-responders host-info))
(responders-servlet (host-responders host-info))
(responders-file-not-found (host-responders host-info))
(timeouts-servlet-connection (host-timeouts host-info))
(timeouts-default-servlet (host-timeouts host-info)))
(files:gen-dispatcher (paths-htdocs (host-paths host-info))
(paths-mime-types (host-paths host-info))
(host-indices host-info)
(responders-file-not-found (host-responders host-info)))))))
(sequencer:make
(log:make #:log-format (host-log-format host-info)
#:log-path (host-log-path host-info))
(passwords:make #:password-file (host-passwords host-info)
#:password-connection-timeout (timeouts-password (host-timeouts host-info))
#:authentication-responder (responders-authentication (host-responders host-info))
#:passwords-refresh-responder (responders-passwords-refreshed (host-responders host-info)))
(path-procedure:make "/conf/collect-garbage"
(lambda ()
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(servlets:make config:instances config:scripts config:make-servlet-namespace
#:servlet-root (paths-servlet (host-paths host-info))
#:responders-servlets-refreshed (responders-servlets-refreshed (host-responders host-info))
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
#:responders-servlet (responders-servlet (host-responders host-info))
#:responders-file-not-found (responders-file-not-found (host-responders host-info))
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
#:mime-types-path (paths-mime-types (host-paths host-info))
#:indices (host-indices host-info)
#:file-not-found-responder (responders-file-not-found (host-responders host-info)))))))
(define web-server@
(compound-unit/sig