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

Fixes PR11072

Browse Source
This commit is contained in:
Jay McCarthy 2010-08-02 09:18:31 -06:00
parent 9e71ccc1eb
commit c7995e247e
6 changed files with 86 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/web-server/private/dispatch-server-sig.rkt
View File

@ -1,10 +1,11 @@
#lang racket #lang racket
(require web-server/private/util (require racket/async-channel
web-server/private/util
web-server/private/connection-manager) web-server/private/connection-manager)
(define-signature dispatch-server^ (define-signature dispatch-server^
((contracted ((contracted
[serve (-> (-> void))] [serve (->* () (#:confirmation-channel (or/c false/c async-channel?)) (-> void))]
[serve-ports (input-port? output-port? . -> . (-> void))]))) [serve-ports (input-port? output-port? . -> . (-> void))])))
(define-signature dispatch-server-config^ (define-signature dispatch-server-config^

15
collects/web-server/private/dispatch-server-unit.rkt
View File

@ -1,5 +1,6 @@
#lang racket/unit #lang racket/unit
(require net/tcp-sig (require net/tcp-sig
racket/async-channel
mzlib/thread) mzlib/thread)
(require "web-server-structs.rkt" (require "web-server-structs.rkt"
"connection-manager.rkt" "connection-manager.rkt"
@ -9,9 +10,13 @@
(import tcp^ (prefix config: dispatch-server-config^)) (import tcp^ (prefix config: dispatch-server-config^))
(export dispatch-server^) (export dispatch-server^)
(define (async-channel-put* ac v)
(when ac
(async-channel-put ac v)))
;; serve: -> -> void ;; serve: -> -> void
;; start the server and return a thunk to shut it down ;; start the server and return a thunk to shut it down
(define (serve) (define (serve #:confirmation-channel [confirmation-channel #f])
(define the-server-custodian (make-custodian)) (define the-server-custodian (make-custodian))
(parameterize ([current-custodian the-server-custodian] (parameterize ([current-custodian the-server-custodian]
[current-server-custodian the-server-custodian] [current-server-custodian the-server-custodian]
@ -27,7 +32,13 @@
(format "Connection error: ~a" (exn-message exn)) (format "Connection error: ~a" (exn-message exn))
exn)) exn))
(lambda (p mw re) (lambda (p mw re)
(tcp-listen p config:max-waiting #t config:listen-ip)) (with-handlers ([exn?
(λ (x)
(async-channel-put* confirmation-channel x)
(raise x))])
(begin0
(tcp-listen p config:max-waiting #t config:listen-ip)
(async-channel-put* confirmation-channel #f))))
tcp-close tcp-close
tcp-accept tcp-accept
tcp-accept/enable-break)))) tcp-accept/enable-break))))

5
collects/web-server/scribblings/dispatch-server.scrbl
View File

@ -7,6 +7,7 @@
web-server/private/util web-server/private/util
web-server/private/connection-manager web-server/private/connection-manager
net/tcp-sig net/tcp-sig
racket/async-channel
racket/tcp racket/tcp
web-server/web-server-sig)) web-server/web-server-sig))
@ -24,8 +25,8 @@ provides two signatures.
The @racket[dispatch-server^] signature is an alias for The @racket[dispatch-server^] signature is an alias for
@racket[web-server^]. @racket[web-server^].
@defproc[(serve) (-> void)]{ @defproc[(serve) (->* () (#:confirmation-channel (or/c false/c async-channel?)) (-> void))]{
Runs the server and returns a procedure that shuts down the server. Runs the server---the confirmation channel will be send an exception if one occurs starting the server or @racket[#f] if the is none---and returns a procedure that shuts down the server.
} }
@defproc[(serve-ports [ip input-port?] @defproc[(serve-ports [ip input-port?]

4
collects/web-server/scribblings/launch.scrbl
View File

@ -10,6 +10,7 @@
web-server/private/dispatch-server-unit web-server/private/dispatch-server-unit
web-server/private/dispatch-server-sig web-server/private/dispatch-server-sig
web-server/dispatchers/dispatch web-server/dispatchers/dispatch
racket/async-channel
web-server/configuration/configuration-table) web-server/configuration/configuration-table)
(prefix-in raw: (for-label net/tcp-unit)) (prefix-in raw: (for-label net/tcp-unit))
(prefix-in files: (for-label web-server/dispatchers/dispatch-files))) (prefix-in files: (for-label web-server/dispatchers/dispatch-files)))
@ -19,6 +20,7 @@
This module provides functions for launching dispatching servers. This module provides functions for launching dispatching servers.
@defproc[(serve [#:dispatch dispatch dispatcher/c] @defproc[(serve [#:dispatch dispatch dispatcher/c]
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
[#:port port integer? 80] [#:port port integer? 80]
[#:listen-ip listen-ip (or/c string? false/c) #f] [#:listen-ip listen-ip (or/c string? false/c) #f]
@ -47,6 +49,7 @@ from a given path:
] ]
@defproc[(serve/ports [#:dispatch dispatch dispatcher/c] @defproc[(serve/ports [#:dispatch dispatch dispatcher/c]
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
[#:ports ports (listof integer?) (list 80)] [#:ports ports (listof integer?) (list 80)]
[#:listen-ip listen-ip (or/c string? false/c) #f] [#:listen-ip listen-ip (or/c string? false/c) #f]
@ -58,6 +61,7 @@ from a given path:
} }
@defproc[(serve/ips+ports [#:dispatch dispatch dispatcher/c] @defproc[(serve/ips+ports [#:dispatch dispatch dispatcher/c]
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
[#:ips+ports ips+ports (listof (cons/c (or/c string? false/c) (listof integer?))) (list (cons #f (list 80)))] [#:ips+ports ips+ports (listof (cons/c (or/c string? false/c) (listof integer?))) (list (cons #f (list 80)))]
[#:max-waiting max-waiting integer? 40] [#:max-waiting max-waiting integer? 40]

87
collects/web-server/servlet-dispatch.rkt
View File

@ -3,6 +3,7 @@
#lang racket #lang racket
(require (prefix-in net: net/sendurl) (require (prefix-in net: net/sendurl)
racket/contract racket/contract
racket/async-channel
racket/list racket/list
racket/unit racket/unit
racket/serialize racket/serialize
@ -25,20 +26,20 @@
(provide/contract (provide/contract
[dispatch/servlet (((request? . -> . response/c)) [dispatch/servlet (((request? . -> . response/c))
(#:regexp regexp? (#:regexp regexp?
#:current-directory path-string? #:current-directory path-string?
#:namespace (listof module-path?) #:namespace (listof module-path?)
#:stateless? boolean? #:stateless? boolean?
#:stuffer (stuffer/c serializable? bytes?) #:stuffer (stuffer/c serializable? bytes?)
#:manager manager?) #:manager manager?)
. ->* . . ->* .
dispatcher/c)] dispatcher/c)]
[serve/launch/wait (((semaphore? . -> . dispatcher/c)) [serve/launch/wait (((semaphore? . -> . dispatcher/c))
(#:launch-path (or/c false/c string?) (#:launch-path (or/c false/c string?)
#:banner? boolean? #:banner? boolean?
#:listen-ip (or/c false/c string?) #:listen-ip (or/c false/c string?)
#:port number? #:port number?
#:ssl-cert (or/c false/c path-string?) #:ssl-cert (or/c false/c path-string?)
#:ssl-key (or/c false/c path-string?)) #:ssl-key (or/c false/c path-string?))
. ->* . . ->* .
void)]) void)])
@ -102,35 +103,47 @@
(string-append (if ssl? "https" "http") (string-append (if ssl? "https" "http")
"://localhost" "://localhost"
(if (and (not ssl?) (= port 80)) (if (and (not ssl?) (= port 80))
"" (format ":~a" port)))) "" (format ":~a" port))))
(define sema (make-semaphore 0)) (define sema (make-semaphore 0))
(define confirm-ch (make-async-channel 1))
(define shutdown-server (define shutdown-server
(serve #:dispatch (dispatcher sema) (serve #:confirmation-channel confirm-ch
#:dispatch (dispatcher sema)
#:listen-ip listen-ip #:listen-ip listen-ip
#:port port #:port port
#:tcp@ (if ssl? #:tcp@ (if ssl?
(let () (let ()
(define-unit-binding ssl-tcp@ (define-unit-binding ssl-tcp@
(make-ssl-tcp@ (make-ssl-tcp@
ssl-cert ssl-key ssl-cert ssl-key
#f #f #f #f #f) #f #f #f #f #f)
(import) (export tcp^)) (import) (export tcp^))
ssl-tcp@) ssl-tcp@)
tcp@))) tcp@)))
(when launch-path (define serve-res (async-channel-get confirm-ch))
((send-url) (string-append server-url launch-path) #t)) (if serve-res
(when banner? (begin
(printf "Your Web application is running at ~a.\n" (when banner? (eprintf "There was an error starting the Web server.\n"))
(if launch-path (match serve-res
(string-append server-url launch-path) [(and (? exn?) (app exn-message (regexp "tcp-listen: listen on .+ failed \\(Address already in use; errno=.+\\)" (list _))))
server-url)) (when banner? (eprintf "\tThe TCP port (~a) is already in use.\n" port))]
(printf "Click 'Stop' at any time to terminate the Web Server.\n")) [_
(let ([bye (lambda () (void)]))
(when banner? (printf "\nWeb Server stopped.\n")) (begin
(shutdown-server))]) (when launch-path
(with-handlers ([exn:break? (lambda (exn) (bye))]) ((send-url) (string-append server-url launch-path) #t))
(semaphore-wait/enable-break sema) (when banner?
; Give the final response time to get there (printf "Your Web application is running at ~a.\n"
(sleep 2) (if launch-path
;; We can get here if a /quit url is visited (string-append server-url launch-path)
(bye)))) server-url))
(printf "Click 'Stop' at any time to terminate the Web Server.\n"))
(let ([bye (lambda ()
(when banner? (printf "\nWeb Server stopped.\n"))
(shutdown-server))])
(with-handlers ([exn:break? (lambda (exn) (bye))])
(semaphore-wait/enable-break sema)
; Give the final response time to get there
(sleep 2)
;; We can get here if a /quit url is visited
(bye))))))

17
collects/web-server/web-server.rkt
View File

@ -3,6 +3,7 @@
net/tcp-sig net/tcp-sig
(prefix-in raw: net/tcp-unit) (prefix-in raw: net/tcp-unit)
racket/unit racket/unit
racket/async-channel
racket/contract racket/contract
web-server/dispatchers/dispatch web-server/dispatchers/dispatch
web-server/private/dispatch-server-sig web-server/private/dispatch-server-sig
@ -14,7 +15,8 @@
(provide/contract (provide/contract
[serve [serve
(->* (#:dispatch dispatcher/c) (->* (#:dispatch dispatcher/c)
(#:tcp@ (unit/c (import) (export tcp^)) (#:confirmation-channel (or/c false/c async-channel?)
#:tcp@ (unit/c (import) (export tcp^))
#:port number? #:port number?
#:listen-ip (or/c false/c string?) #:listen-ip (or/c false/c string?)
#:max-waiting number? #:max-waiting number?
@ -22,7 +24,8 @@
(-> void))] (-> void))]
[serve/ports [serve/ports
(->* (#:dispatch dispatcher/c) (->* (#:dispatch dispatcher/c)
(#:tcp@ (unit/c (import) (export tcp^)) (#:confirmation-channel (or/c false/c async-channel?)
#:tcp@ (unit/c (import) (export tcp^))
#:ports (listof number?) #:ports (listof number?)
#:listen-ip (or/c false/c string?) #:listen-ip (or/c false/c string?)
#:max-waiting number? #:max-waiting number?
@ -30,7 +33,8 @@
(-> void))] (-> void))]
[serve/ips+ports [serve/ips+ports
(->* (#:dispatch dispatcher/c) (->* (#:dispatch dispatcher/c)
(#:tcp@ (unit/c (import) (export tcp^)) (#:confirmation-channel (or/c false/c async-channel?)
#:tcp@ (unit/c (import) (export tcp^))
#:ips+ports (listof (cons/c (or/c false/c string?) (listof number?))) #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?)))
#:max-waiting number? #:max-waiting number?
#:initial-connection-timeout number?) #:initial-connection-timeout number?)
@ -43,6 +47,7 @@
(define (serve (define (serve
#:dispatch dispatch #:dispatch dispatch
#:confirmation-channel [confirmation-channel #f]
#:tcp@ [tcp@ raw:tcp@] #:tcp@ [tcp@ raw:tcp@]
#:port [port 80] #:port [port 80]
#:listen-ip [listen-ip #f] #:listen-ip [listen-ip #f]
@ -60,10 +65,11 @@
(import dispatch-server-config^) (import dispatch-server-config^)
(export dispatch-server^)) (export dispatch-server^))
(serve)) (serve #:confirmation-channel confirmation-channel))
(define (serve/ports (define (serve/ports
#:dispatch dispatch #:dispatch dispatch
#:confirmation-channel [confirmation-channel #f]
#:tcp@ [tcp@ raw:tcp@] #:tcp@ [tcp@ raw:tcp@]
#:ports [ports (list 80)] #:ports [ports (list 80)]
#:listen-ip [listen-ip #f] #:listen-ip [listen-ip #f]
@ -72,6 +78,7 @@
(define shutdowns (define shutdowns
(map (lambda (port) (map (lambda (port)
(serve #:dispatch dispatch (serve #:dispatch dispatch
#:confirmation-channel confirmation-channel
#:tcp@ tcp@ #:tcp@ tcp@
#:port port #:port port
#:listen-ip listen-ip #:listen-ip listen-ip
@ -83,6 +90,7 @@
(define (serve/ips+ports (define (serve/ips+ports
#:dispatch dispatch #:dispatch dispatch
#:confirmation-channel [confirmation-channel #f]
#:tcp@ [tcp@ raw:tcp@] #:tcp@ [tcp@ raw:tcp@]
#:ips+ports [ips+ports (list (cons #f (list 80)))] #:ips+ports [ips+ports (list (cons #f (list 80)))]
#:max-waiting [max-waiting 40] #:max-waiting [max-waiting 40]
@ -91,6 +99,7 @@
(map (match-lambda (map (match-lambda
[(list-rest listen-ip ports) [(list-rest listen-ip ports)
(serve #:dispatch dispatch (serve #:dispatch dispatch
#:confirmation-channel confirmation-channel
#:tcp@ tcp@ #:tcp@ tcp@
#:ports ports #:ports ports
#:listen-ip listen-ip #:listen-ip listen-ip