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
(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^

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

@ -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))))

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

@ -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?]

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

@ -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]

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

@ -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))))))

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

@ -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