diff --git a/collects/web-server/connection-manager.ss b/collects/web-server/connection-manager.ss index d529199b3d..09bfef016f 100644 --- a/collects/web-server/connection-manager.ss +++ b/collects/web-server/connection-manager.ss @@ -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)))) ) diff --git a/collects/web-server/request-parsing.ss b/collects/web-server/request-parsing.ss index 3b4317a656..be4cbbba6d 100644 --- a/collects/web-server/request-parsing.ss +++ b/collects/web-server/request-parsing.ss @@ -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=(.*)")) diff --git a/collects/web-server/response.ss b/collects/web-server/response.ss index 4ae4526c08..b0f845609a 100644 --- a/collects/web-server/response.ss +++ b/collects/web-server/response.ss @@ -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 diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 6e50050dee..3587a84db5 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -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