diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index f54748fc04..fc408806b8 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -83,7 +83,7 @@ ((responders-servlet-loading (host-responders host-info)) uri the-exn) - (request-method req)))]) + (request-method req)))]) (let ([sema (make-semaphore 0)] [last-inst (thread-cell-ref current-servlet-instance)]) (let/cc suspend diff --git a/collects/web-server/request-parsing.ss b/collects/web-server/request-parsing.ss index 8ef6972c78..6783243511 100644 --- a/collects/web-server/request-parsing.ss +++ b/collects/web-server/request-parsing.ss @@ -14,16 +14,16 @@ ;; The part of the URL path that gets passed to the servlet as arguments. (provide/contract - [read-request ((connection? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))] + [read-request ((connection? number? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))] [read-bindings (connection? symbol? url? (listof header?) . -> . (union (listof binding?) string?))]) ;; ************************************************** - ;; read-request: connection (input-port -> string string) -> request boolean? + ;; read-request: connection number (input-port -> string string) -> request boolean? ;; read the request line, and the headers, determine if the connection should ;; be closed after servicing the request and build a request structure - (define (read-request conn port-addresses) + (define (read-request conn host-port port-addresses) (call-with-semaphore (connection-mutex conn) (lambda () @@ -33,7 +33,7 @@ (let ([headers (read-headers ip)]) (let-values ([(host-ip client-ip) (port-addresses ip)]) (values - (make-request method uri headers '() host-ip client-ip) + (make-request method uri headers '() host-ip host-port client-ip) (close-connection? headers major-version minor-version client-ip host-ip))))))))) diff --git a/collects/web-server/request-structs.ss b/collects/web-server/request-structs.ss index 0b2534f328..2cbaeb1ae3 100644 --- a/collects/web-server/request-structs.ss +++ b/collects/web-server/request-structs.ss @@ -3,7 +3,8 @@ (lib "url.ss" "net")) ;; the request struct as currently doc'd - (define-struct request (method uri headers bindings/raw host-ip client-ip)) + (define-struct request (method uri headers bindings/raw + host-ip host-port client-ip)) ;; header?: anyd/c -> boolean ;; is this a header? @@ -21,5 +22,5 @@ (provide/contract [struct request ([method symbol?] [uri url?] [headers (listof header?)] [bindings/raw (union (listof binding?) string?)] - [host-ip string?] + [host-ip string?] [host-port number?] [client-ip string?])])) \ No newline at end of file diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index 01b1f0e84c..bb2b8d494e 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -1,14 +1,36 @@ ;; Default choice for writing module servlets (module servlet mzscheme (require (lib "contract.ss") - (lib "etc.ss")) + (lib "etc.ss") + (lib "xml.ss" "xml")) (require "servlet-tables.ss" "response.ss" "servlet-helpers.ss" - "xexpr-callback.ss" "timer.ss" "web-cells.ss") + ;; ************************************************************ + ;; HELPERS + + ;; Is it a Xexpr, or an Xexpr with procedures? + (define (xexpr/callback? x) + (correct-xexpr? x + (lambda () #t) + (lambda (exn) + (if (procedure? (exn:invalid-xexpr-code exn)) + #t + (begin ((error-display-handler) (exn-message exn) exn) + #f))))) + + ;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr? + ;; Change procedures to the send/suspend of a k-url + (define (xexpr/callback->xexpr p->a p-exp) + (cond + [(list? p-exp) (map (lambda (p-e) (xexpr/callback->xexpr p->a p-e)) + p-exp)] + [(procedure? p-exp) (p->a p-exp)] + [else p-exp])) + ;; Weak contracts: the input is checked in output-response, and a message is ;; sent directly to the client (Web browser) instead of the terminal/log. (provide/contract @@ -25,9 +47,10 @@ clear-continuation-table! send/suspend/dispatch current-servlet-continuation-expiration-handler + xexpr/callback? + xexpr/callback->xexpr (all-from "web-cells.ss") - (all-from "servlet-helpers.ss") - (all-from "xexpr-callback.ss")) + (all-from "servlet-helpers.ss")) ;; ************************************************************ ;; HIGHER-LEVEL EXPORTS @@ -101,13 +124,6 @@ (clear-continuation-table!) (send/suspend response-generator expiration-handler))) - ;; send/suspend/callback : xexpr/callback? -> void - ;; send/back a response with callbacks in it; send/suspend those callbacks. - (define (send/suspend/callback p-exp) - (send/suspend/dispatch - (lambda (embed/url) - (replace-procedures p-exp embed/url)))) - ;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request ;; send/back a response generated from a procedure that may convert ;; procedures to continuation urls @@ -117,18 +133,10 @@ (response-generator (opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) (let/ec k1 (k0 (proc (send/suspend k1 expiration-handler))))))))) - - - ;; ************************************************************ - ;; HELPERS - - ;; replace-procedures : xexpr/callbacks? (xexpr/callbacks? -> xexpr?) -> xexpr? - ;; Change procedures to the send/suspend of a k-url - (define (replace-procedures p-exp p->a) - (cond - ((list? p-exp) (map (lambda (p-e) (replace-procedures p-e p->a)) - p-exp)) - ((procedure? p-exp) (p->a p-exp)) - (else p-exp))) - -) + + ;; send/suspend/callback : xexpr/callback? -> void + ;; send/back a response with callbacks in it; send/suspend those callbacks. + (define (send/suspend/callback p-exp) + (send/suspend/dispatch + (lambda (embed/url) + (xexpr/callback->xexpr embed/url p-exp))))) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index f9aba19f78..92ca4cbc00 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -120,7 +120,7 @@ ;; respond to all requests on this connection (define (serve-connection conn port-addresses) (let connection-loop () - (let-values ([(req close?) (config:read-request conn port-addresses)]) + (let-values ([(req close?) (config:read-request conn config:port port-addresses)]) (set-connection-close?! conn close?) (adjust-connection-timeout! conn config:initial-connection-timeout) (config:dispatch conn req) diff --git a/collects/web-server/xexpr-callback.ss b/collects/web-server/xexpr-callback.ss index bed1b78e9c..8f32b7182d 100644 --- a/collects/web-server/xexpr-callback.ss +++ b/collects/web-server/xexpr-callback.ss @@ -11,4 +11,7 @@ (correct-xexpr? x (lambda () #t) (lambda (exn) - (procedure? (exn:invalid-xexpr-code exn)))))) + (if (procedure? (exn:invalid-xexpr-code exn)) + #t + (begin ((error-display-handler) (exn-message exn) exn) + #f))))))