From 703a5e8fc96eae8cdc80667a57fff1f40507d497 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 19 Sep 2006 16:19:12 +0000 Subject: [PATCH] privacy svn: r4385 --- .../status-web-root/servlets/status.ss | 2 +- .../web-server/dispatchers/dispatch-files.ss | 3 +- .../dispatchers/dispatch-passwords.ss | 2 +- .../dispatchers/dispatch-pathprocedure.ss | 3 +- .../dispatchers/dispatch-servlets.ss | 3 +- collects/web-server/private/configuration.ss | 2 +- collects/web-server/private/response.ss | 327 +++++++++++++++++ .../web-server/private/servlet-helpers.ss | 2 +- collects/web-server/response-structs.ss | 5 +- collects/web-server/response.ss | 334 +----------------- collects/web-server/tools/servlet-env.ss | 2 +- 11 files changed, 344 insertions(+), 341 deletions(-) create mode 100644 collects/web-server/private/response.ss diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index dc1d8c5fd8..2f4885f776 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/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")) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index ff5ba833e9..1d025909b7 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/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 diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 44ece62fd2..7eea224bb9 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/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 diff --git a/collects/web-server/dispatchers/dispatch-pathprocedure.ss b/collects/web-server/dispatchers/dispatch-pathprocedure.ss index ca35590709..616589f752 100644 --- a/collects/web-server/dispatchers/dispatch-pathprocedure.ss +++ b/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?)]) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 48ce9fe0cd..55ce318cb8 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/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" diff --git a/collects/web-server/private/configuration.ss b/collects/web-server/private/configuration.ss index 99933e1f76..b8e7dd4fce 100644 --- a/collects/web-server/private/configuration.ss +++ b/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) diff --git a/collects/web-server/private/response.ss b/collects/web-server/private/response.ss new file mode 100644 index 0000000000..8d3a20aa20 --- /dev/null +++ b/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 + "Erroneous Xexpr" + "

Erroneous Xexpr

" + "

An Xexpr in the servlet is malformed. The exact error is

" + "
" (exn-message exn) "
" + "

The Full Xexpr Is

" + "
"
+       (let ([o (open-output-string)])
+         (parameterize ([current-output-port o])
+           (pretty-print-invalid-xexpr exn x))
+         (get-output-string o))
+       "
")))) + + (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 + "" + (if display? "~a" "~v") + "") + v))]) + (pretty-print xexpr)))) \ No newline at end of file diff --git a/collects/web-server/private/servlet-helpers.ss b/collects/web-server/private/servlet-helpers.ss index 5cccf0ea23..cbfd87bd4f 100644 --- a/collects/web-server/private/servlet-helpers.ss +++ b/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")) diff --git a/collects/web-server/response-structs.ss b/collects/web-server/response-structs.ss index 337c15e7ab..0171922c24 100644 --- a/collects/web-server/response-structs.ss +++ b/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?)])) \ No newline at end of file + [response? (any/c . -> . boolean?)] + [TEXT/HTML-MIME-TYPE bytes?])) \ No newline at end of file diff --git a/collects/web-server/response.ss b/collects/web-server/response.ss index 3c421e61e3..30ef0e18ec 100644 --- a/collects/web-server/response.ss +++ b/collects/web-server/response.ss @@ -1,333 +1,3 @@ (module response mzscheme - (require (lib "list.ss") - (lib "contract.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 - "Erroneous Xexpr" - "

Erroneous Xexpr

" - "

An Xexpr in the servlet is malformed. The exact error is

" - "
" (exn-message exn) "
" - "

The Full Xexpr Is

" - "
"
-       (let ([o (open-output-string)])
-         (parameterize ([current-output-port o])
-           (pretty-print-invalid-xexpr exn x))
-         (get-output-string o))
-       "
")))) - - (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 - "" - (if display? "~a" "~v") - "") - v))]) - (pretty-print xexpr)))) \ No newline at end of file + (require "response-structs.ss") + (provide (all-from "response-structs.ss"))) \ No newline at end of file diff --git a/collects/web-server/tools/servlet-env.ss b/collects/web-server/tools/servlet-env.ss index 1d0d381c80..3a255f71a7 100644 --- a/collects/web-server/tools/servlet-env.ss +++ b/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")