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

style

Browse Source 
svn: r3223
This commit is contained in:
Jay McCarthy 2006-06-04 22:46:59 +00:00
parent b462f7cf2c
commit 8dcbfb3128
1 changed files with 58 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -28,42 +28,43 @@
;; serve: -> -> void
;; start the server and return a thunk to shut it down
(define (serve)
(let ([the-server-custodian (make-custodian)])
(start-connection-manager the-server-custodian)
(parameterize ([current-custodian the-server-custodian]
[current-server-custodian the-server-custodian]
[current-thread-initial-stack-size 3])
(thread
(lambda ()
(start-listener))))
(lambda ()
(custodian-shutdown-all the-server-custodian))))
(define the-server-custodian (make-custodian))
(start-connection-manager the-server-custodian)
(parameterize ([current-custodian the-server-custodian]
[current-server-custodian the-server-custodian]
[current-thread-initial-stack-size 3])
(thread
(lambda ()
(start-listener))))
(lambda ()
(custodian-shutdown-all the-server-custodian)))
;; start-listener : -> void
;; loops around starting a listener if the current listener dies
(define (start-listener)
(let* ([listener (tcp-listen config:port config:max-waiting
#t config:listen-ip)]
[get-ports
(lambda () (tcp-accept listener))])
(with-handlers ([void (lambda (e)
; If the exception did not kill the listener
(with-handlers ([void void])
(tcp-close listener))
; Rethrow the error to this thread's error printer
(raise e))])
(server-loop get-ports
tcp-addresses))))
(define listener
(tcp-listen config:port config:max-waiting
#t config:listen-ip))
(define get-ports
(lambda () (tcp-accept listener)))
(with-handlers ([void (lambda (e)
; If the exception did not kill the listener
(with-handlers ([void void])
(tcp-close listener))
; Rethrow the error to this thread's error printer
(raise e))])
(server-loop get-ports
tcp-addresses)))
;; server-loop: (-> input-port output-port) (input-port -> string string) -> void
;; start a thread to handle each incoming connection
(define (server-loop get-ports port-addresses)
(let loop ()
(let ([connection-cust (make-custodian)])
(parameterize ([current-custodian connection-cust])
(let-values ([(ip op) (get-ports)])
(serve-ports/inner ip op
port-addresses))))
(define connection-cust (make-custodian))
(parameterize ([current-custodian connection-cust])
(define-values (ip op) (get-ports))
(serve-ports/inner ip op
port-addresses))
(loop)))
;; serve-ports : input-port output-port -> void
@ -71,44 +72,45 @@
;; the connection
;; NOTE: (GregP) should allow the user to pass in a connection-custodian
(define (serve-ports ip op)
(let ([server-cust (make-custodian)])
(start-connection-manager server-cust)
(parameterize ([current-custodian server-cust]
[current-server-custodian server-cust])
(let ([connection-cust (make-custodian)])
(parameterize ([current-custodian connection-cust])
(serve-ports/inner ip op
(lambda (ip)
(values "127.0.0.1"
"127.0.0.1"))))))))
(define server-cust (make-custodian))
(start-connection-manager server-cust)
(parameterize ([current-custodian server-cust]
[current-server-custodian server-cust])
(define connection-cust (make-custodian))
(parameterize ([current-custodian connection-cust])
(serve-ports/inner ip op
(lambda (ip)
(values "127.0.0.1"
"127.0.0.1"))))))
;; serve-ports/inner : input-port output-port (input-port -> string string) -> void
;; returns immediately, spawning a thread to handle
(define (serve-ports/inner ip op port-addresses)
(thread
(lambda ()
(let ([conn (new-connection config:initial-connection-timeout
ip op (current-custodian) #f)])
(with-handlers ([exn:fail:network?
(lambda (e)
(kill-connection! conn)
(raise e))])
(serve-connection conn port-addresses))))))
(define conn
(new-connection config:initial-connection-timeout
ip op (current-custodian) #f))
(with-handlers ([exn:fail:network?
(lambda (e)
(kill-connection! conn)
(raise e))])
(serve-connection conn port-addresses)))))
;; serve-connection: connection (input-port -> string string) -> void
;; respond to all requests on this connection
(define (serve-connection conn port-addresses)
(let connection-loop ()
(let-values ([(req close?) (config:read-request conn config:port port-addresses)])
(unless close?
(set-connection-close?! conn #f))
(adjust-connection-timeout! conn config:initial-connection-timeout)
(config:dispatch conn req)
(when close?
(set-connection-close?! conn #t))
(cond
[(connection-close? conn) (kill-connection! conn)]
[else (connection-loop)]))))))
(define-values (req close?) (config:read-request conn config:port port-addresses))
(unless close?
(set-connection-close?! conn #f))
(adjust-connection-timeout! conn config:initial-connection-timeout)
(config:dispatch conn req)
(when close?
(set-connection-close?! conn #t))
(cond
[(connection-close? conn) (kill-connection! conn)]
[else (connection-loop)])))))
(define web-config@->dispatch-server-config@
(unit/sig dispatch-server-config^
@ -122,7 +124,7 @@
;; dispatch : connection request -> void
(define dispatch
(let* ([cache (make-cache-table)])
(let ([cache (make-cache-table)])
(host:gen-dispatcher
(lambda (host)
(cache-table-lookup!
@ -165,4 +167,4 @@
(web-config@->dispatch-server-config@ CONFIG))
(DISPATCH : dispatch-server^
(dispatch-server@ TCP DISPATCH-CONFIG)))
(export (open (DISPATCH : web-server^))))))
(export (open (DISPATCH : web-server^))))))