suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PR 7450

Browse Source 
svn: r630
This commit is contained in:
Jay McCarthy 2005-08-22 13:17:49 +00:00
parent dee9ff17be
commit ef1caf7465
4 changed files with 145 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
collects/web-server/connection-manager.ss
View File

@ -5,44 +5,54 @@
(module connection-manager mzscheme
(require "timer.ss"
(lib "contract.ss"))
(define-struct connection (timer i-port o-port custodian close?)
(define-struct connection (timer i-port o-port custodian close? mutex)
(make-inspector))
(provide/contract
[struct connection
([timer timer?]
[i-port input-port?] [o-port output-port?] [custodian custodian?]
[close? boolean?])]
[close? boolean?] [mutex semaphore?])]
[start-connection-manager (custodian? . -> . void)]
[new-connection (number? input-port? output-port? custodian? boolean? . -> . connection?)]
[kill-connection! (connection? . -> . void)]
[adjust-connection-timeout! (connection? number? . -> . void)])
;; start-connection-manager: custodian -> void
;; does nothing
(define start-connection-manager void)
;; new-connection: number i-port o-port custodian -> connection
;; ask the connection manager for a new connection
(define (new-connection time-to-live i-port o-port cust close?)
(make-connection
(start-timer time-to-live
(lambda ()
(close-output-port o-port)
(close-input-port i-port)
(custodian-shutdown-all cust)))
i-port o-port cust close?))
(let ([mutex (make-semaphore 1)])
(make-connection
(start-timer time-to-live
(lambda ()
(call-with-semaphore
mutex
(lambda ()
(close-output-port o-port)
(close-input-port i-port)
(custodian-shutdown-all cust)))))
i-port o-port cust close? mutex)))
;; kill-connection!: connection -> void
;; kill this connection
(define (kill-connection! conn-demned)
(close-output-port (connection-o-port conn-demned))
(close-input-port (connection-i-port conn-demned))
(custodian-shutdown-all (connection-custodian conn-demned)))
(call-with-semaphore
(connection-mutex conn-demned)
(lambda ()
(close-output-port (connection-o-port conn-demned))
(close-input-port (connection-i-port conn-demned))
(custodian-shutdown-all (connection-custodian conn-demned)))))
;; adjust-connection-timeout!: connection number -> void
;; change the expiration time for this connection
(define (adjust-connection-timeout! conn time)
(reset-timer (connection-timer conn) time))
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(reset-timer (connection-timer conn) time))))
)

79
collects/web-server/request-parsing.ss
View File

@ -32,7 +32,7 @@
[bindings (union (listof binding?) string?)]
[host-ip string?]
[client-ip string?])]
[read-request ((input-port?) . ->* . (request? boolean?))]
[read-request ((connection?) . ->* . (request? boolean?))]
[read-bindings (connection? symbol? url? (listof header?)
. -> . (union (listof binding?) string?))])
@ -40,18 +40,22 @@
;; read-request: input-port -> request boolean?
;; read the request line, and the headers, determine if the connection should
;; be closed after servicing the request and build a request structure
(define (read-request ip)
(let-values ([(method uri major-version minor-version)
(read-request-line ip)])
(let ([headers (read-headers ip)])
(let-values ([(host-ip client-ip)
(if (tcp-port? ip)
(tcp-addresses ip)
(values "127.0.0.1" "127.0.0.1"))])
(values
(make-request method uri headers '() host-ip client-ip)
(close-connection?
headers major-version minor-version client-ip host-ip))))))
(define (read-request conn)
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(let ([ip (connection-i-port conn)])
(let-values ([(method uri major-version minor-version)
(read-request-line ip)])
(let ([headers (read-headers ip)])
(let-values ([(host-ip client-ip)
(if (tcp-port? ip)
(tcp-addresses ip)
(values "127.0.0.1" "127.0.0.1"))])
(values
(make-request method uri headers '() host-ip client-ip)
(close-connection?
headers major-version minor-version client-ip host-ip)))))))))
;; **************************************************
;; close-connection?
@ -164,29 +168,32 @@
(case meth
[(get) (url-query uri)]
[(post)
(let ([content-type (assq 'content-type headers)])
(cond
[(and content-type (regexp-match FILE-FORM-REGEXP (cdr content-type)))
=> (lambda (content-boundary)
(map (lambda (part)
;; more here - better checks, avoid string-append
(cons (get-field-name (cdr (assq 'content-disposition (car part))))
(apply bytes-append (cdr part))))
(read-mime-multipart (cadr content-boundary) (connection-i-port conn))))]
[else
(let ([len-str (assq 'content-length headers)]
[in (connection-i-port conn)])
(if len-str
(cond
[(string->number (bytes->string/utf-8 (cdr len-str)))
=> (lambda (len) (read-string len in))]
[else (error "Post request contained a non-numeric content-length")])
(apply string-append
(let read-to-eof ()
(let ([s (read-string INPUT-BUFFER-SIZE in)])
(if (eof-object? s)
null
(cons s (read-to-eof))))))))]))]
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(let ([content-type (assq 'content-type headers)])
(cond
[(and content-type (regexp-match FILE-FORM-REGEXP (cdr content-type)))
=> (lambda (content-boundary)
(map (lambda (part)
;; more here - better checks, avoid string-append
(cons (get-field-name (cdr (assq 'content-disposition (car part))))
(apply bytes-append (cdr part))))
(read-mime-multipart (cadr content-boundary) (connection-i-port conn))))]
[else
(let ([len-str (assq 'content-length headers)]
[in (connection-i-port conn)])
(if len-str
(cond
[(string->number (bytes->string/utf-8 (cdr len-str)))
=> (lambda (len) (read-string len in))]
[else (error "Post request contained a non-numeric content-length")])
(apply string-append
(let read-to-eof ()
(let ([s (read-string INPUT-BUFFER-SIZE in)])
(if (eof-object? s)
null
(cons s (read-to-eof))))))))]))))]
[else (error "unsupported method" meth)]))
(define FILE-FORM-REGEXP (regexp "multipart/form-data; *boundary=(.*)"))

133
collects/web-server/response.ss
View File

@ -181,53 +181,56 @@
;; **************************************************
;; 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) (string? (car resp)))
(output-response/basic
conn
(make-response/basic 200 "Okay" (current-seconds) (car resp) '())
(apply + (map
(lambda (c)
(if (string? c)
(string-length c)
(bytes-length c)))
(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 (string-length str))
(lambda (o-port)
(display str o-port)
(newline o-port)))))]))
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(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) (string? (car resp)))
(output-response/basic
conn
(make-response/basic 200 "Okay" (current-seconds) (car resp) '())
(apply + (map
(lambda (c)
(if (string? c)
(string-length c)
(bytes-length c)))
(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 (string-length str))
(lambda (o-port)
(display str o-port)
(newline o-port)))))]))))
;; response/full->size: response/full -> number
;; compute the size for a response/full
@ -242,26 +245,32 @@
;; **************************************************
;; 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))
(call-with-input-file file-path
(lambda (i-port) (copy-port i-port (connection-o-port conn))))))
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(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))
(call-with-input-file file-path
(lambda (i-port) (copy-port i-port (connection-o-port conn))))))))
;; **************************************************
;; 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)]))
(call-with-semaphore
(connection-mutex conn)
(lambda ()
(cond
[(eqv? meth 'head)
(output-headers/response conn resp `(("Content-length: "
,(response/full->size resp))))]
[else
(output-response conn resp)]))))
;; **************************************************
;; output-headers/response: connection response (listof (listof string)) -> void

7
collects/web-server/web-server-unit.ss
View File

@ -113,7 +113,7 @@
;; respond to all requests on this connection
(define (serve-connection conn)
(let connection-loop ()
(let-values ([(req close?) (read-request (connection-i-port conn))])
(let-values ([(req close?) (read-request conn)])
(let* ([host (get-host (request-uri req) (request-headers req))]
[host-conf (config:virtual-hosts host)])
((host-log-message host-conf) (request-host-ip req)
@ -125,8 +125,6 @@
[close? (kill-connection! conn)]
[else (connection-loop)])))))
;; dispatch: connection request host -> void
;; NOTE: (GregP) I'm going to use the dispatch logic out of v208 for now.
;; I will move the other dispatch logic out of the prototype
@ -161,8 +159,7 @@
(output-response/method
conn
((responders-passwords-refreshed (host-responders host-info)))
method)
]
method)]
[else
(output-response/method
conn