Adding host-port and xexpr-callbacks message

svn: r1220

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

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

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

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

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)

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