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

Fix of address lookup for SSL

Browse Source 
svn: r832
This commit is contained in:
Jay McCarthy 2005-09-11 17:31:23 +00:00
parent 07598376bd
commit 700c36eccd
2 changed files with 20 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,16 +14,16 @@
;; The part of the URL path that gets passed to the servlet as arguments. ;; The part of the URL path that gets passed to the servlet as arguments.
(provide/contract (provide/contract
[read-request ((connection?) . ->* . (request? boolean?))] [read-request ((connection? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))]
[read-bindings (connection? symbol? url? (listof header?) [read-bindings (connection? symbol? url? (listof header?)
. -> . (union (listof binding?) string?))]) . -> . (union (listof binding?) string?))])
;; ************************************************** ;; **************************************************
;; read-request: input-port -> request boolean? ;; read-request: connection (input-port -> string string) -> request boolean?
;; read the request line, and the headers, determine if the connection should ;; read the request line, and the headers, determine if the connection should
;; be closed after servicing the request and build a request structure ;; be closed after servicing the request and build a request structure
(define (read-request conn) (define (read-request conn port-addresses)
(call-with-semaphore (call-with-semaphore
(connection-mutex conn) (connection-mutex conn)
(lambda () (lambda ()
@ -31,10 +31,7 @@
(let-values ([(method uri major-version minor-version) (let-values ([(method uri major-version minor-version)
(read-request-line ip)]) (read-request-line ip)])
(let ([headers (read-headers ip)]) (let ([headers (read-headers ip)])
(let-values ([(host-ip client-ip) (let-values ([(host-ip client-ip) (port-addresses ip)])
(if (tcp-port? ip)
(tcp-addresses ip)
(values "127.0.0.1" "127.0.0.1"))])
(values (values
(make-request method uri headers '() host-ip client-ip) (make-request method uri headers '() host-ip client-ip)
(close-connection? (close-connection?

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

@ -77,18 +77,20 @@
(semaphore-post sema) (semaphore-post sema)
; Rethrow the error to this thread's error printer ; Rethrow the error to this thread's error printer
(raise e))]) (raise e))])
(server-loop get-ports)))))) (server-loop get-ports
tcp-addresses))))))
(semaphore-wait sema) (semaphore-wait sema)
(loop)))) (loop))))
;; server-loop: (-> i-port o-port) -> void ;; server-loop: (-> input-port output-port) (input-port -> string string) -> void
;; start a thread to handle each incoming connection ;; start a thread to handle each incoming connection
(define (server-loop get-ports) (define (server-loop get-ports port-addresses)
(let loop () (let loop ()
(let ([connection-cust (make-custodian)]) (let ([connection-cust (make-custodian)])
(parameterize ([current-custodian connection-cust]) (parameterize ([current-custodian connection-cust])
(let-values ([(ip op) (get-ports)]) (let-values ([(ip op) (get-ports)])
(serve-ports/inner ip op)))) (serve-ports/inner ip op
port-addresses))))
(loop))) (loop)))
;; serve-ports : input-port output-port -> void ;; serve-ports : input-port output-port -> void
@ -102,11 +104,14 @@
[current-server-custodian server-cust]) [current-server-custodian server-cust])
(let ([connection-cust (make-custodian)]) (let ([connection-cust (make-custodian)])
(parameterize ([current-custodian connection-cust]) (parameterize ([current-custodian connection-cust])
(serve-ports/inner ip op)))))) (serve-ports/inner ip op
(lambda (ip)
(values "127.0.0.1"
"127.0.0.1"))))))))
;; serve-ports/inner : input-port output-port -> void ;; serve-ports/inner : input-port output-port (input-port -> string string) -> void
;; returns immediately, spawning a thread to handle ;; returns immediately, spawning a thread to handle
(define (serve-ports/inner ip op) (define (serve-ports/inner ip op port-addresses)
(thread (thread
(lambda () (lambda ()
(let ([conn (new-connection config:initial-connection-timeout (let ([conn (new-connection config:initial-connection-timeout
@ -116,13 +121,13 @@
(set-connection-close?! conn #t) (set-connection-close?! conn #t)
(kill-connection! conn) (kill-connection! conn)
(raise e))]) (raise e))])
(serve-connection conn)))))) (serve-connection conn port-addresses))))))
;; serve-connection: connection -> void ;; serve-connection: connection (input-port -> string string) -> void
;; respond to all requests on this connection ;; respond to all requests on this connection
(define (serve-connection conn) (define (serve-connection conn port-addresses)
(let connection-loop () (let connection-loop ()
(let-values ([(req close?) (config:read-request conn)]) (let-values ([(req close?) (config:read-request conn port-addresses)])
(set-connection-close?! conn close?) (set-connection-close?! conn close?)
(adjust-connection-timeout! conn config:initial-connection-timeout) (adjust-connection-timeout! conn config:initial-connection-timeout)
(config:dispatch conn req) (config:dispatch conn req)