Fixes PR11072
This commit is contained in:
parent
9e71ccc1eb
commit
c7995e247e
|
@ -1,10 +1,11 @@
|
|||
#lang racket
|
||||
(require web-server/private/util
|
||||
(require racket/async-channel
|
||||
web-server/private/util
|
||||
web-server/private/connection-manager)
|
||||
|
||||
(define-signature dispatch-server^
|
||||
((contracted
|
||||
[serve (-> (-> void))]
|
||||
[serve (->* () (#:confirmation-channel (or/c false/c async-channel?)) (-> void))]
|
||||
[serve-ports (input-port? output-port? . -> . (-> void))])))
|
||||
|
||||
(define-signature dispatch-server-config^
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/unit
|
||||
(require net/tcp-sig
|
||||
racket/async-channel
|
||||
mzlib/thread)
|
||||
(require "web-server-structs.rkt"
|
||||
"connection-manager.rkt"
|
||||
|
@ -9,9 +10,13 @@
|
|||
(import tcp^ (prefix config: dispatch-server-config^))
|
||||
(export dispatch-server^)
|
||||
|
||||
(define (async-channel-put* ac v)
|
||||
(when ac
|
||||
(async-channel-put ac v)))
|
||||
|
||||
;; serve: -> -> void
|
||||
;; 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))
|
||||
(parameterize ([current-custodian the-server-custodian]
|
||||
[current-server-custodian the-server-custodian]
|
||||
|
@ -27,7 +32,13 @@
|
|||
(format "Connection error: ~a" (exn-message exn))
|
||||
exn))
|
||||
(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-accept
|
||||
tcp-accept/enable-break))))
|
||||
|
|
|
@ -7,6 +7,7 @@
|
|||
web-server/private/util
|
||||
web-server/private/connection-manager
|
||||
net/tcp-sig
|
||||
racket/async-channel
|
||||
racket/tcp
|
||||
web-server/web-server-sig))
|
||||
|
||||
|
@ -24,8 +25,8 @@ provides two signatures.
|
|||
The @racket[dispatch-server^] signature is an alias for
|
||||
@racket[web-server^].
|
||||
|
||||
@defproc[(serve) (-> void)]{
|
||||
Runs the server and returns a procedure that shuts down the server.
|
||||
@defproc[(serve) (->* () (#:confirmation-channel (or/c false/c async-channel?)) (-> void))]{
|
||||
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?]
|
||||
|
|
|
@ -10,6 +10,7 @@
|
|||
web-server/private/dispatch-server-unit
|
||||
web-server/private/dispatch-server-sig
|
||||
web-server/dispatchers/dispatch
|
||||
racket/async-channel
|
||||
web-server/configuration/configuration-table)
|
||||
(prefix-in raw: (for-label net/tcp-unit))
|
||||
(prefix-in files: (for-label web-server/dispatchers/dispatch-files)))
|
||||
|
@ -19,6 +20,7 @@
|
|||
This module provides functions for launching dispatching servers.
|
||||
|
||||
@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@]
|
||||
[#:port port integer? 80]
|
||||
[#: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]
|
||||
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
|
||||
[#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@]
|
||||
[#:ports ports (listof integer?) (list 80)]
|
||||
[#: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]
|
||||
[#:confirmation-channel confirmation-channel (or/c false/c async-channel?) #f]
|
||||
[#: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)))]
|
||||
[#:max-waiting max-waiting integer? 40]
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
#lang racket
|
||||
(require (prefix-in net: net/sendurl)
|
||||
racket/contract
|
||||
racket/async-channel
|
||||
racket/list
|
||||
racket/unit
|
||||
racket/serialize
|
||||
|
@ -25,20 +26,20 @@
|
|||
(provide/contract
|
||||
[dispatch/servlet (((request? . -> . response/c))
|
||||
(#:regexp regexp?
|
||||
#:current-directory path-string?
|
||||
#:namespace (listof module-path?)
|
||||
#:stateless? boolean?
|
||||
#:stuffer (stuffer/c serializable? bytes?)
|
||||
#:manager manager?)
|
||||
#:current-directory path-string?
|
||||
#:namespace (listof module-path?)
|
||||
#:stateless? boolean?
|
||||
#:stuffer (stuffer/c serializable? bytes?)
|
||||
#:manager manager?)
|
||||
. ->* .
|
||||
dispatcher/c)]
|
||||
[serve/launch/wait (((semaphore? . -> . dispatcher/c))
|
||||
(#:launch-path (or/c false/c string?)
|
||||
#:banner? boolean?
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:port number?
|
||||
#:ssl-cert (or/c false/c path-string?)
|
||||
#:ssl-key (or/c false/c path-string?))
|
||||
#:banner? boolean?
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:port number?
|
||||
#:ssl-cert (or/c false/c path-string?)
|
||||
#:ssl-key (or/c false/c path-string?))
|
||||
. ->* .
|
||||
void)])
|
||||
|
||||
|
@ -102,35 +103,47 @@
|
|||
(string-append (if ssl? "https" "http")
|
||||
"://localhost"
|
||||
(if (and (not ssl?) (= port 80))
|
||||
"" (format ":~a" port))))
|
||||
"" (format ":~a" port))))
|
||||
(define sema (make-semaphore 0))
|
||||
(define confirm-ch (make-async-channel 1))
|
||||
(define shutdown-server
|
||||
(serve #:dispatch (dispatcher sema)
|
||||
(serve #:confirmation-channel confirm-ch
|
||||
#:dispatch (dispatcher sema)
|
||||
#:listen-ip listen-ip
|
||||
#:port port
|
||||
#:tcp@ (if ssl?
|
||||
(let ()
|
||||
(define-unit-binding ssl-tcp@
|
||||
(make-ssl-tcp@
|
||||
ssl-cert ssl-key
|
||||
#f #f #f #f #f)
|
||||
(import) (export tcp^))
|
||||
ssl-tcp@)
|
||||
tcp@)))
|
||||
(when launch-path
|
||||
((send-url) (string-append server-url launch-path) #t))
|
||||
(when banner?
|
||||
(printf "Your Web application is running at ~a.\n"
|
||||
(if launch-path
|
||||
(string-append server-url launch-path)
|
||||
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))))
|
||||
(let ()
|
||||
(define-unit-binding ssl-tcp@
|
||||
(make-ssl-tcp@
|
||||
ssl-cert ssl-key
|
||||
#f #f #f #f #f)
|
||||
(import) (export tcp^))
|
||||
ssl-tcp@)
|
||||
tcp@)))
|
||||
(define serve-res (async-channel-get confirm-ch))
|
||||
(if serve-res
|
||||
(begin
|
||||
(when banner? (eprintf "There was an error starting the Web server.\n"))
|
||||
(match serve-res
|
||||
[(and (? exn?) (app exn-message (regexp "tcp-listen: listen on .+ failed \\(Address already in use; errno=.+\\)" (list _))))
|
||||
(when banner? (eprintf "\tThe TCP port (~a) is already in use.\n" port))]
|
||||
[_
|
||||
(void)]))
|
||||
(begin
|
||||
(when launch-path
|
||||
((send-url) (string-append server-url launch-path) #t))
|
||||
(when banner?
|
||||
(printf "Your Web application is running at ~a.\n"
|
||||
(if launch-path
|
||||
(string-append server-url launch-path)
|
||||
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))))))
|
||||
|
|
|
@ -3,6 +3,7 @@
|
|||
net/tcp-sig
|
||||
(prefix-in raw: net/tcp-unit)
|
||||
racket/unit
|
||||
racket/async-channel
|
||||
racket/contract
|
||||
web-server/dispatchers/dispatch
|
||||
web-server/private/dispatch-server-sig
|
||||
|
@ -14,7 +15,8 @@
|
|||
(provide/contract
|
||||
[serve
|
||||
(->* (#: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?
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:max-waiting number?
|
||||
|
@ -22,7 +24,8 @@
|
|||
(-> void))]
|
||||
[serve/ports
|
||||
(->* (#: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?)
|
||||
#:listen-ip (or/c false/c string?)
|
||||
#:max-waiting number?
|
||||
|
@ -30,7 +33,8 @@
|
|||
(-> void))]
|
||||
[serve/ips+ports
|
||||
(->* (#: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?)))
|
||||
#:max-waiting number?
|
||||
#:initial-connection-timeout number?)
|
||||
|
@ -43,6 +47,7 @@
|
|||
|
||||
(define (serve
|
||||
#:dispatch dispatch
|
||||
#:confirmation-channel [confirmation-channel #f]
|
||||
#:tcp@ [tcp@ raw:tcp@]
|
||||
#:port [port 80]
|
||||
#:listen-ip [listen-ip #f]
|
||||
|
@ -60,10 +65,11 @@
|
|||
(import dispatch-server-config^)
|
||||
(export dispatch-server^))
|
||||
|
||||
(serve))
|
||||
(serve #:confirmation-channel confirmation-channel))
|
||||
|
||||
(define (serve/ports
|
||||
#:dispatch dispatch
|
||||
#:confirmation-channel [confirmation-channel #f]
|
||||
#:tcp@ [tcp@ raw:tcp@]
|
||||
#:ports [ports (list 80)]
|
||||
#:listen-ip [listen-ip #f]
|
||||
|
@ -72,6 +78,7 @@
|
|||
(define shutdowns
|
||||
(map (lambda (port)
|
||||
(serve #:dispatch dispatch
|
||||
#:confirmation-channel confirmation-channel
|
||||
#:tcp@ tcp@
|
||||
#:port port
|
||||
#:listen-ip listen-ip
|
||||
|
@ -83,6 +90,7 @@
|
|||
|
||||
(define (serve/ips+ports
|
||||
#:dispatch dispatch
|
||||
#:confirmation-channel [confirmation-channel #f]
|
||||
#:tcp@ [tcp@ raw:tcp@]
|
||||
#:ips+ports [ips+ports (list (cons #f (list 80)))]
|
||||
#:max-waiting [max-waiting 40]
|
||||
|
@ -91,6 +99,7 @@
|
|||
(map (match-lambda
|
||||
[(list-rest listen-ip ports)
|
||||
(serve #:dispatch dispatch
|
||||
#:confirmation-channel confirmation-channel
|
||||
#:tcp@ tcp@
|
||||
#:ports ports
|
||||
#:listen-ip listen-ip
|
||||
|
|
Loading…
Reference in New Issue
Block a user