privacy

svn: r4385

collects/handin-server/status-web-root/servlets/status.ss

@@ -6,7 +6,7 @@
 	   (lib "date.ss")
 	   (lib "unitsig.ss")
 	   (lib "servlet-sig.ss" "web-server")
-	   (lib "response.ss" "web-server")
+	   (lib "response-structs.ss" "web-server")
 	   (lib "md5.ss" "handin-server")
 	   (lib "uri-codec.ss" "net"))
 

collects/web-server/dispatchers/dispatch-files.ss

@@ -12,7 +12,8 @@
            "../private/mime-types.ss"
            "../private/request.ss"
            "../private/servlet-helpers.ss"
-           "../response.ss")
+           "../private/response.ss"
+           "../response-structs.ss")
   (provide/contract
    [interface-version dispatcher-interface-version?])
   (provide ; XXX contract kw

collects/web-server/dispatchers/dispatch-passwords.ss

@@ -6,7 +6,7 @@
            "../private/configuration.ss"
            "../private/servlet-helpers.ss"
            "../private/connection-manager.ss"
-           "../response.ss")  
+           "../private/response.ss")  
   (provide/contract
    [interface-version dispatcher-interface-version?])
   (provide ; XXX contract kw

collects/web-server/dispatchers/dispatch-pathprocedure.ss

@@ -2,7 +2,8 @@
   (require (lib "contract.ss"))
   (require "dispatch.ss"
            "../private/util.ss"
-           "../response.ss")
+           "../private/response.ss"
+           "../response-structs.ss")
   (provide/contract
    [interface-version dispatcher-interface-version?]
    [make (string? (-> response?) . -> . dispatcher?)])

collects/web-server/dispatchers/dispatch-servlets.ss

@@ -7,7 +7,8 @@
   (require "dispatch.ss"
            "../private/web-server-structs.ss"
            "../private/connection-manager.ss"
-           "../response.ss"
+           "../private/response.ss"
+           "../response-structs.ss"
            "../servlet.ss"
            "../sig.ss"
            "../private/configuration.ss"

collects/web-server/private/configuration.ss

@@ -6,7 +6,7 @@
            "util.ss"
            "cache-table.ss"
            "../sig.ss"
-           "../response.ss")
+           "../response-structs.ss")
         
   ; : str configuration-table/vhosts -> configuration
   (define (complete-developer-configuration/vhosts base table)

collects/web-server/private/response.ss

@@ -0,0 +1,327 @@
+(module response mzscheme
+  (require (lib "contract.ss")
+           (lib "port.ss")
+           (lib "pretty.ss")
+           (lib "xml.ss" "xml")
+           "connection-manager.ss"
+           "../response-structs.ss"
+           "util.ss")
+  
+  ;; Weak contracts for output-response because the response? is checked inside
+  ;; output-response, handled, etc.
+  (provide/contract
+   [rename ext:output-response output-response (connection? any/c . -> . any)]
+   [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . any)]
+   [rename ext:output-file output-file (connection? path? symbol? bytes? . -> . any)]
+   ; XXX add contract
+   [rename ext:output-file/partial output-file/partial (connection? path? symbol? bytes? integer? integer? . -> . any)])
+  
+  ;; Table 1. head responses:
+  ; ------------------------------------------------------------------------------
+  ; |method | close? | x-fer coding || response actions
+  ; |-----------------------------------------------------------------------------
+  ; |-----------------------------------------------------------------------------
+  ; |head   |   #t   | chunked      || 1. Output the headers only.
+  ; |-------------------------------|| 2. Add the special connection-close header.
+  ; |head   |   #t   | not-chunked  ||
+  ; |-----------------------------------------------------------------------------
+  ; |head   |   #f   | chunked      || 1. Output the headers only.
+  ; |-------------------------------|| 2. Don't add the connection-close header.
+  ; |head   |   #f   | not-chunked  ||
+  ; |-----------------------------------------------------------------------------
+  
+  ;; Table 2. get responses:
+  ; ------------------------------------------------------------------------------
+  ; |method | x-fer-coding | close? || response actions
+  ; |-----------------------------------------------------------------------------
+  ; |-----------------------------------------------------------------------------
+  ; | get   | chunked      |   #t   || 1. Output headers as above.
+  ; |       |              |        || 2. Generate trivial chunked response.
+  ; |-----------------------------------------------------------------------------
+  ; | get   | chunked      |   #f   || 1. Output headers as above.
+  ; |       |              |        || 2. Generate chunks as per RFC 2616 sec. 3.6
+  ; |-----------------------------------------------------------------------------
+  ; | get   | not chunked  |   #t   || 1. Output headers as above.
+  ; |-------------------------------|| 2. Generate usual non-chunked response.
+  ; | get   | not chunked  |   #f   ||
+  ; |-----------------------------------------------------------------------------
+  
+  ;; Notes:
+  ;; 1. close? is a boolean which corresponds roughly to the protocol version.
+  ;;    #t |-> 1.0 and #f |-> 1.1. See function close-connection? in
+  ;;    private/request.ss
+  ;;
+  ;; 2. In the case of a chunked response when close? = #f, then the response
+  ;;    must be compliant with http 1.0. In this case the chunked response is
+  ;;    simply turned into a non-chunked one.
+  (define (data-length x)
+    (if (string? x)
+        (data-length (string->bytes/utf-8 x))
+        (bytes-length x)))
+  
+  ;;**************************************************
+  ;; output-headers: connection number string (listof (listof String))
+  ;;                 number string -> void
+  ;; Write the headers portion of a response to an output port.
+  ;; NOTE: According to RFC 2145 the server should write HTTP/1.1
+  ;;       header for *all* clients.
+  (define (output-headers conn code message extras seconds mime)
+    (let ([o-port (connection-o-port conn)])
+      (for-each
+       (lambda (line)
+         (for-each
+          (lambda (word) (display word o-port))
+          line)
+         (fprintf o-port "\r\n"))
+       (list* `("HTTP/1.1 " ,code " " ,message)
+              `("Date: " ,(seconds->gmt-string (current-seconds)))
+              `("Last-Modified: " ,(seconds->gmt-string seconds))
+              `("Server: PLT Scheme")
+              `("Content-Type: " ,mime)
+              (if (connection-close? conn)
+                  (cons `("Connection: close") extras)
+                  extras)))
+      (fprintf o-port "\r\n")))
+  
+  ; seconds->gmt-string : Nat -> String
+  ; format is rfc1123 compliant according to rfc2068 (http/1.1)
+  (define (seconds->gmt-string s)
+    (let* ([local-date (seconds->date s)]
+           [date (seconds->date (- s
+                                   (date-time-zone-offset local-date)
+                                   (if (date-dst? local-date) 3600 0)))])
+      (format "~a, ~a ~a ~a ~a:~a:~a GMT"
+              (vector-ref DAYS (date-week-day date))
+              (two-digits (date-day date))
+              (vector-ref MONTHS (sub1 (date-month date)))
+              (date-year date)
+              (two-digits (date-hour date))
+              (two-digits (date-minute date))
+              (two-digits (date-second date)))))
+  
+  ; two-digits : num -> str
+  (define (two-digits n)
+    (let ([str (number->string n)])
+      (if (< n 10) (string-append "0" str) str)))
+  
+  (define MONTHS
+    #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+  
+  (define DAYS
+    #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+  
+  (define (ext:wrap f)
+    (lambda (conn . args)
+      (if (connection-close? conn)
+          (error 'output-response "Attempt to write to closed connection.")
+          (with-handlers ([exn? (lambda (exn)
+                                  (kill-connection! conn)
+                                  (raise exn))])
+            (call-with-semaphore (connection-mutex conn)
+                                 (lambda ()
+                                   (apply f conn args)
+                                   (flush-output (connection-o-port conn))))))))
+  
+  
+  ;; **************************************************
+  ;; output-response: connection response -> void
+  (define (output-response conn resp)
+    (cond
+      [(response/full? resp)
+       (output-response/basic
+        conn resp (response/full->size resp)
+        (lambda (o-port)
+          (for-each
+           (lambda (str) (display str o-port))
+           (response/full-body resp))))]
+      [(response/incremental? resp)
+       (output-response/incremental conn resp)]
+      [(and (pair? resp) (bytes? (car resp)))
+       (output-response/basic
+        conn
+        (make-response/basic 200 "Okay" (current-seconds) (car resp) '())
+        (apply + (map
+                  data-length
+                  (cdr resp)))
+        (lambda (o-port)
+          (for-each
+           (lambda (str) (display str o-port))
+           (cdr resp))))]
+      [else
+       ;; TODO: make a real exception for this.
+       (with-handlers
+           ([exn:invalid-xexpr?
+             (lambda (exn)
+               (output-response/method
+                conn
+                (xexpr-exn->response exn resp)
+                'ignored))]
+            [exn? (lambda (exn)
+                    (raise exn))])
+         (let ([str (and (validate-xexpr resp) (xexpr->string resp))])
+           (output-response/basic
+            conn
+            (make-response/basic 200
+                                 "Okay"
+                                 (current-seconds)
+                                 TEXT/HTML-MIME-TYPE
+                                 '())
+            (add1 (data-length str))
+            (lambda (o-port)
+              (display str o-port)
+              (newline o-port)))))]))
+  
+  (define ext:output-response
+    (ext:wrap output-response))
+  
+  ;; response/full->size: response/full -> number
+  ;; compute the size for a response/full
+  (define (response/full->size resp/f)
+    (apply + (map
+              data-length
+              (response/full-body resp/f))))
+  
+  ;; **************************************************
+  ;; output-file: connection path symbol bytes -> void
+  (define (output-file conn file-path method mime-type)
+    (output-headers conn 200 "Okay"
+                    `(("Content-Length: " ,(file-size file-path)))
+                    (file-or-directory-modify-seconds file-path)
+                    mime-type)
+    (when (eq? method 'get)
+      ; Give it one second per byte.
+      (adjust-connection-timeout! conn (file-size file-path))
+      (with-handlers ([void (lambda (e) (network-error 'output-file (exn-message e)))])
+        (call-with-input-file file-path
+          (lambda (i-port) (copy-port i-port (connection-o-port conn)))))))
+  
+  ;; **************************************************
+  ;; output-file/partial: connection path symbol bytes integer integer -> void
+  (define (output-file/partial conn file-path method mime-type
+                               start end-or-inf)
+    (define total-len (file-size file-path))
+    (define end (if (equal? +inf.0 end-or-inf)
+                    total-len
+                    end-or-inf))
+    (define len (- end start))
+    (output-headers conn 206 "Okay"
+                    `(("Content-Length: " ,len)
+                      ("Content-Range: " ,(format "bytes ~a-~a/~a" start end total-len)))
+                    (file-or-directory-modify-seconds file-path)
+                    mime-type)
+    (when (eq? method 'get)
+      ; Give it one second per byte.
+      (adjust-connection-timeout! conn len)
+      (with-handlers ([void (lambda (e) (network-error 'output-file/partial (exn-message e)))])
+        (call-with-input-file file-path
+          (lambda (i-port)
+            (define _ (file-position i-port start))
+            (define i-port/end (make-limited-input-port i-port end #t))
+            (copy-port i-port/end (connection-o-port conn)))))))
+  
+  (define ext:output-file
+    (ext:wrap output-file))
+  
+  (define ext:output-file/partial    
+    (ext:wrap output-file/partial))
+  
+  ;; **************************************************
+  ;; output-response/method: connection response/full symbol -> void
+  ;; If it is a head request output headers only, otherwise output as usual
+  (define (output-response/method conn resp meth)
+    (cond
+      [(eqv? meth 'head)
+       (output-headers/response conn resp `(("Content-Length: "
+                                             ,(response/full->size resp))))]
+      [else
+       (output-response conn resp)]))
+  
+  (define ext:output-response/method
+    (ext:wrap output-response/method))
+  
+  ;; **************************************************
+  ;; output-headers/response: connection response (listof (listof string)) -> void
+  ;; Write the headers for a response to an output port
+  (define (output-headers/response conn resp extras)
+    (output-headers conn
+                    (response/basic-code resp)
+                    (response/basic-message resp)
+                    extras
+                    (response/basic-seconds resp)
+                    (response/basic-mime resp)))
+  
+  ;; **************************************************
+  ;; output-response/basic: connection response number (o-port -> void) -> void
+  ;; Write a normal response to an output port
+  (define (output-response/basic conn resp size responder)
+    (output-headers/response conn resp
+                             `(("Content-Length: " ,size)
+                               . ,(extras->strings resp)))
+    (responder (connection-o-port conn)))
+  
+  ;; **************************************************
+  ;; output-response/incremental: connection response/incremental -> void
+  ;; Write a chunked response to an output port.
+  (define (output-response/incremental conn resp/inc)
+    (let ([o-port (connection-o-port conn)])
+      (cond
+        [(connection-close? conn)
+         (output-headers/response conn resp/inc '())
+         ((response/incremental-generator resp/inc)
+          (lambda chunks
+            (for-each (lambda (chunk) (display chunk o-port)) chunks)))]
+        [else
+         (output-headers/response conn resp/inc
+                                  `(("Transfer-Encoding: chunked")
+                                    . ,(extras->strings resp/inc)))
+         ((response/incremental-generator resp/inc)
+          (lambda chunks
+            (fprintf o-port "~x\r\n"
+                     (apply + 0 (map data-length chunks)))                     
+            (for-each (lambda (chunk) (display chunk o-port)) chunks)
+            (fprintf o-port "\r\n")))
+         ; one \r\n ends the last (empty) chunk and the second \r\n ends the (non-existant) trailers
+         (fprintf o-port "0\r\n\r\n")])))
+  
+  ;; extras->strings: response/basic -> (listof (listof string))
+  ;; convert the response/basic-extras to the form used by output-headers
+  (define (extras->strings r/bas)
+    (map
+     (lambda (xtra)
+       (list (symbol->string (car xtra)) ": " (cdr xtra)))
+     (response/basic-extras r/bas)))
+  
+  ;; Turn an exn:invalid-xexpr into a response.
+  (define (xexpr-exn->response exn x)
+    (make-response/full
+     500 "Servlet Error"
+     (current-seconds)
+     #"text/html"
+     '()
+     (list
+      (string-append
+       "<html><head><title>Erroneous Xexpr</title></head>"
+       "<body><h1>Erroneous Xexpr</h1>"
+       "<p>An Xexpr in the servlet is malformed. The exact error is</p>"
+       "<pre>" (exn-message exn) "</pre>"
+       "<h2>The Full Xexpr Is</h2>"
+       "<pre>"
+       (let ([o (open-output-string)])
+         (parameterize ([current-output-port o])
+           (pretty-print-invalid-xexpr exn x))
+         (get-output-string o))
+       "</pre>"))))
+  
+  (define (pretty-print-invalid-xexpr exn xexpr)
+    (define code (exn:invalid-xexpr-code exn))
+    (parameterize ([pretty-print-size-hook (lambda (v display? out)
+                                             (and (equal? v code)
+                                                  (string-length (format (if display? "~a" "~v") v))))]
+                   [pretty-print-print-hook (lambda (v display? out)
+                                              (fprintf out
+                                                       (string-append
+                                                        "<font color=\"red\">"
+                                                        (if display? "~a" "~v")
+                                                        "</font>")
+                                                       v))])
+      (pretty-print xexpr))))

collects/web-server/private/servlet-helpers.ss

@@ -9,7 +9,7 @@
            "bindings.ss"
            "../servlet-structs.ss"
            "../request-structs.ss"
-           "../response.ss")
+           "../response-structs.ss")
   (provide (all-from "bindings.ss")
            (all-from "../request-structs.ss"))  
   

collects/web-server/response-structs.ss

@@ -2,6 +2,8 @@
   (require (lib "contract.ss")
            (lib "xml.ss" "xml"))
   
+  (define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8")
+  
   ;; **************************************************
   ;; (make-response/basic number string number string  (listof (cons symbol string)))
   (define-struct response/basic (code message seconds mime extras))
@@ -64,4 +66,5 @@
             [extras (listof (cons/c symbol? string?))]
             [generator ((() (listof (or/c bytes? string?)) . ->* . any) . ->
                                                                          . any)])]
-   [response? (any/c . -> . boolean?)]))
+   [response? (any/c . -> . boolean?)]
+   [TEXT/HTML-MIME-TYPE bytes?]))

collects/web-server/response.ss

@@ -1,333 +1,3 @@
 (module response mzscheme
-  (require (lib "list.ss")
+  (require "response-structs.ss")
-           (lib "contract.ss")
+  (provide (all-from "response-structs.ss")))
-           (lib "port.ss")
-           (lib "pretty.ss")
-           (lib "xml.ss" "xml")
-           (lib "string.ss" "srfi" "13")
-           "private/connection-manager.ss"
-           "response-structs.ss"
-           "private/util.ss")
-  (provide (all-from "response-structs.ss"))
-  
-  ;; Weak contracts for output-response because the response? is checked inside
-  ;; output-response, handled, etc.
-  (provide/contract
-   [rename ext:output-response output-response (connection? any/c . -> . any)]
-   [rename ext:output-response/method output-response/method (connection? response? symbol? . -> . any)]
-   [rename ext:output-file output-file (connection? path? symbol? bytes? . -> . any)]
-   ; XXX add contract
-   [rename ext:output-file/partial output-file/partial (connection? path? symbol? bytes? integer? integer? . -> . any)]
-   [TEXT/HTML-MIME-TYPE bytes?])
-  
-  ;; Table 1. head responses:
-  ; ------------------------------------------------------------------------------
-  ; |method | close? | x-fer coding || response actions
-  ; |-----------------------------------------------------------------------------
-  ; |-----------------------------------------------------------------------------
-  ; |head   |   #t   | chunked      || 1. Output the headers only.
-  ; |-------------------------------|| 2. Add the special connection-close header.
-  ; |head   |   #t   | not-chunked  ||
-  ; |-----------------------------------------------------------------------------
-  ; |head   |   #f   | chunked      || 1. Output the headers only.
-  ; |-------------------------------|| 2. Don't add the connection-close header.
-  ; |head   |   #f   | not-chunked  ||
-  ; |-----------------------------------------------------------------------------
-  
-  ;; Table 2. get responses:
-  ; ------------------------------------------------------------------------------
-  ; |method | x-fer-coding | close? || response actions
-  ; |-----------------------------------------------------------------------------
-  ; |-----------------------------------------------------------------------------
-  ; | get   | chunked      |   #t   || 1. Output headers as above.
-  ; |       |              |        || 2. Generate trivial chunked response.
-  ; |-----------------------------------------------------------------------------
-  ; | get   | chunked      |   #f   || 1. Output headers as above.
-  ; |       |              |        || 2. Generate chunks as per RFC 2616 sec. 3.6
-  ; |-----------------------------------------------------------------------------
-  ; | get   | not chunked  |   #t   || 1. Output headers as above.
-  ; |-------------------------------|| 2. Generate usual non-chunked response.
-  ; | get   | not chunked  |   #f   ||
-  ; |-----------------------------------------------------------------------------
-  
-  ;; Notes:
-  ;; 1. close? is a boolean which corresponds roughly to the protocol version.
-  ;;    #t |-> 1.0 and #f |-> 1.1. See function close-connection? in
-  ;;    private/request.ss
-  ;;
-  ;; 2. In the case of a chunked response when close? = #f, then the response
-  ;;    must be compliant with http 1.0. In this case the chunked response is
-  ;;    simply turned into a non-chunked one.
-  
-  (define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8")
-  (define (data-length x)
-    (if (string? x)
-        (data-length (string->bytes/utf-8 x))
-        (bytes-length x)))
-  
-  ;;**************************************************
-  ;; output-headers: connection number string (listof (listof String))
-  ;;                 number string -> void
-  ;; Write the headers portion of a response to an output port.
-  ;; NOTE: According to RFC 2145 the server should write HTTP/1.1
-  ;;       header for *all* clients.
-  (define (output-headers conn code message extras seconds mime)
-    (let ([o-port (connection-o-port conn)])
-      (for-each
-       (lambda (line)
-         (for-each
-          (lambda (word) (display word o-port))
-          line)
-         (fprintf o-port "\r\n"))
-       (list* `("HTTP/1.1 " ,code " " ,message)
-              `("Date: " ,(seconds->gmt-string (current-seconds)))
-              `("Last-Modified: " ,(seconds->gmt-string seconds))
-              `("Server: PLT Scheme")
-              `("Content-Type: " ,mime)
-              (if (connection-close? conn)
-                  (cons `("Connection: close") extras)
-                  extras)))
-      (fprintf o-port "\r\n")))
-  
-  ; seconds->gmt-string : Nat -> String
-  ; format is rfc1123 compliant according to rfc2068 (http/1.1)
-  (define (seconds->gmt-string s)
-    (let* ([local-date (seconds->date s)]
-           [date (seconds->date (- s
-                                   (date-time-zone-offset local-date)
-                                   (if (date-dst? local-date) 3600 0)))])
-      (format "~a, ~a ~a ~a ~a:~a:~a GMT"
-              (vector-ref DAYS (date-week-day date))
-              (two-digits (date-day date))
-              (vector-ref MONTHS (sub1 (date-month date)))
-              (date-year date)
-              (two-digits (date-hour date))
-              (two-digits (date-minute date))
-              (two-digits (date-second date)))))
-  
-  ; two-digits : num -> str
-  (define (two-digits n)
-    (let ([str (number->string n)])
-      (if (< n 10) (string-append "0" str) str)))
-  
-  (define MONTHS
-    #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
-  
-  (define DAYS
-    #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
-  
-  (define (ext:wrap f)
-    (lambda (conn . args)
-      (if (connection-close? conn)
-          (error 'output-response "Attempt to write to closed connection.")
-          (with-handlers ([exn? (lambda (exn)
-                                  (kill-connection! conn)
-                                  (raise exn))])
-            (call-with-semaphore (connection-mutex conn)
-                                 (lambda ()
-                                   (apply f conn args)
-                                   (flush-output (connection-o-port conn))))))))
-  
-  
-  ;; **************************************************
-  ;; output-response: connection response -> void
-  (define (output-response conn resp)
-    (cond
-      [(response/full? resp)
-       (output-response/basic
-        conn resp (response/full->size resp)
-        (lambda (o-port)
-          (for-each
-           (lambda (str) (display str o-port))
-           (response/full-body resp))))]
-      [(response/incremental? resp)
-       (output-response/incremental conn resp)]
-      [(and (pair? resp) (bytes? (car resp)))
-       (output-response/basic
-        conn
-        (make-response/basic 200 "Okay" (current-seconds) (car resp) '())
-        (apply + (map
-                  data-length
-                  (cdr resp)))
-        (lambda (o-port)
-          (for-each
-           (lambda (str) (display str o-port))
-           (cdr resp))))]
-      [else
-       ;; TODO: make a real exception for this.
-       (with-handlers
-           ([exn:invalid-xexpr?
-             (lambda (exn)
-               (output-response/method
-                conn
-                (xexpr-exn->response exn resp)
-                'ignored))]
-            [exn? (lambda (exn)
-                    (raise exn))])
-         (let ([str (and (validate-xexpr resp) (xexpr->string resp))])
-           (output-response/basic
-            conn
-            (make-response/basic 200
-                                 "Okay"
-                                 (current-seconds)
-                                 TEXT/HTML-MIME-TYPE
-                                 '())
-            (add1 (data-length str))
-            (lambda (o-port)
-              (display str o-port)
-              (newline o-port)))))]))
-  
-  (define ext:output-response
-    (ext:wrap output-response))
-  
-  ;; response/full->size: response/full -> number
-  ;; compute the size for a response/full
-  (define (response/full->size resp/f)
-    (apply + (map
-              data-length
-              (response/full-body resp/f))))
-  
-  ;; **************************************************
-  ;; output-file: connection path symbol bytes -> void
-  (define (output-file conn file-path method mime-type)
-    (output-headers conn 200 "Okay"
-                    `(("Content-Length: " ,(file-size file-path)))
-                    (file-or-directory-modify-seconds file-path)
-                    mime-type)
-    (when (eq? method 'get)
-      ; Give it one second per byte.
-      (adjust-connection-timeout! conn (file-size file-path))
-      (with-handlers ([void (lambda (e) (network-error 'output-file (exn-message e)))])
-        (call-with-input-file file-path
-          (lambda (i-port) (copy-port i-port (connection-o-port conn)))))))
-  
-  ;; **************************************************
-  ;; output-file/partial: connection path symbol bytes integer integer -> void
-  (define (output-file/partial conn file-path method mime-type
-                               start end-or-inf)
-    (define total-len (file-size file-path))
-    (define end (if (equal? +inf.0 end-or-inf)
-                    total-len
-                    end-or-inf))
-    (define len (- end start))
-    (output-headers conn 206 "Okay"
-                    `(("Content-Length: " ,len)
-                      ("Content-Range: " ,(format "bytes ~a-~a/~a" start end total-len)))
-                    (file-or-directory-modify-seconds file-path)
-                    mime-type)
-    (when (eq? method 'get)
-      ; Give it one second per byte.
-      (adjust-connection-timeout! conn len)
-      (with-handlers ([void (lambda (e) (network-error 'output-file/partial (exn-message e)))])
-        (call-with-input-file file-path
-          (lambda (i-port)
-            (define _ (file-position i-port start))
-            (define i-port/end (make-limited-input-port i-port end #t))
-            (copy-port i-port/end (connection-o-port conn)))))))
-  
-  (define ext:output-file
-    (ext:wrap output-file))
-  
-  (define ext:output-file/partial    
-    (ext:wrap output-file/partial))
-  
-  ;; **************************************************
-  ;; output-response/method: connection response/full symbol -> void
-  ;; If it is a head request output headers only, otherwise output as usual
-  (define (output-response/method conn resp meth)
-    (cond
-      [(eqv? meth 'head)
-       (output-headers/response conn resp `(("Content-Length: "
-                                             ,(response/full->size resp))))]
-      [else
-       (output-response conn resp)]))
-  
-  (define ext:output-response/method
-    (ext:wrap output-response/method))
-  
-  ;; **************************************************
-  ;; output-headers/response: connection response (listof (listof string)) -> void
-  ;; Write the headers for a response to an output port
-  (define (output-headers/response conn resp extras)
-    (output-headers conn
-                    (response/basic-code resp)
-                    (response/basic-message resp)
-                    extras
-                    (response/basic-seconds resp)
-                    (response/basic-mime resp)))
-  
-  ;; **************************************************
-  ;; output-response/basic: connection response number (o-port -> void) -> void
-  ;; Write a normal response to an output port
-  (define (output-response/basic conn resp size responder)
-    (output-headers/response conn resp
-                             `(("Content-Length: " ,size)
-                               . ,(extras->strings resp)))
-    (responder (connection-o-port conn)))
-  
-  ;; **************************************************
-  ;; output-response/incremental: connection response/incremental -> void
-  ;; Write a chunked response to an output port.
-  (define (output-response/incremental conn resp/inc)
-    (let ([o-port (connection-o-port conn)])
-      (cond
-        [(connection-close? conn)
-         (output-headers/response conn resp/inc '())
-         ((response/incremental-generator resp/inc)
-          (lambda chunks
-            (for-each (lambda (chunk) (display chunk o-port)) chunks)))]
-        [else
-         (output-headers/response conn resp/inc
-                                  `(("Transfer-Encoding: chunked")
-                                    . ,(extras->strings resp/inc)))
-         ((response/incremental-generator resp/inc)
-          (lambda chunks
-            (fprintf o-port "~x\r\n"
-                     (apply + 0 (map data-length chunks)))                     
-            (for-each (lambda (chunk) (display chunk o-port)) chunks)
-            (fprintf o-port "\r\n")))
-         ; one \r\n ends the last (empty) chunk and the second \r\n ends the (non-existant) trailers
-         (fprintf o-port "0\r\n\r\n")])))
-  
-  ;; extras->strings: response/basic -> (listof (listof string))
-  ;; convert the response/basic-extras to the form used by output-headers
-  (define (extras->strings r/bas)
-    (map
-     (lambda (xtra)
-       (list (symbol->string (car xtra)) ": " (cdr xtra)))
-     (response/basic-extras r/bas)))
-  
-  ;; Turn an exn:invalid-xexpr into a response.
-  (define (xexpr-exn->response exn x)
-    (make-response/full
-     500 "Servlet Error"
-     (current-seconds)
-     #"text/html"
-     '()
-     (list
-      (string-append
-       "<html><head><title>Erroneous Xexpr</title></head>"
-       "<body><h1>Erroneous Xexpr</h1>"
-       "<p>An Xexpr in the servlet is malformed. The exact error is</p>"
-       "<pre>" (exn-message exn) "</pre>"
-       "<h2>The Full Xexpr Is</h2>"
-       "<pre>"
-       (let ([o (open-output-string)])
-         (parameterize ([current-output-port o])
-           (pretty-print-invalid-xexpr exn x))
-         (get-output-string o))
-       "</pre>"))))
-  
-  (define (pretty-print-invalid-xexpr exn xexpr)
-    (define code (exn:invalid-xexpr-code exn))
-    (parameterize ([pretty-print-size-hook (lambda (v display? out)
-                                             (and (equal? v code)
-                                                  (string-length (format (if display? "~a" "~v") v))))]
-                   [pretty-print-print-hook (lambda (v display? out)
-                                              (fprintf out
-                                                       (string-append
-                                                        "<font color=\"red\">"
-                                                        (if display? "~a" "~v")
-                                                        "</font>")
-                                                       v))])
-      (pretty-print xexpr))))

collects/web-server/tools/servlet-env.ss

@@ -5,7 +5,7 @@
            "../web-server.ss"
            "../sig.ss"
            "../private/util.ss"
-           "../response.ss"
+           "../response-structs.ss"
            "../managers/timeouts.ss"
            "../private/servlet.ss"
            "../private/cache-table.ss")