privacy
svn: r4385
This commit is contained in:
Jay McCarthy
parent
10ab002a3e
commit
703a5e8fc9
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?)])
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
327
collects/web-server/private/response.ss
Normal file
327
collects/web-server/private/response.ss
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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"))
|
||||
|
||||
|
|
|
|||
|
|
@ -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?]))
|
||||
|
|
@ -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
|
||||
"<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))))
|
||||
(require "response-structs.ss")
|
||||
(provide (all-from "response-structs.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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user