From c7995e247e8300d5b7b634c789a5d5e732a7a74e Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 2 Aug 2010 09:18:31 -0600
Subject: [PATCH] Fixes PR11072

---
 .../private/dispatch-server-sig.rkt           |  5 +-
 .../private/dispatch-server-unit.rkt          | 15 +++-
 .../scribblings/dispatch-server.scrbl         |  5 +-
 collects/web-server/scribblings/launch.scrbl  |  4 +
 collects/web-server/servlet-dispatch.rkt      | 87 +++++++++++--------
 collects/web-server/web-server.rkt            | 17 +++-
 6 files changed, 86 insertions(+), 47 deletions(-)

diff --git a/collects/web-server/private/dispatch-server-sig.rkt b/collects/web-server/private/dispatch-server-sig.rkt
index 29b3fc9ee4..e7a280700e 100644
--- a/collects/web-server/private/dispatch-server-sig.rkt
+++ b/collects/web-server/private/dispatch-server-sig.rkt
@@ -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^
diff --git a/collects/web-server/private/dispatch-server-unit.rkt b/collects/web-server/private/dispatch-server-unit.rkt
index a3c61d4f6a..5d0c7fd2b3 100644
--- a/collects/web-server/private/dispatch-server-unit.rkt
+++ b/collects/web-server/private/dispatch-server-unit.rkt
@@ -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))))
diff --git a/collects/web-server/scribblings/dispatch-server.scrbl b/collects/web-server/scribblings/dispatch-server.scrbl
index c51bbf4f95..35dfe2befa 100644
--- a/collects/web-server/scribblings/dispatch-server.scrbl
+++ b/collects/web-server/scribblings/dispatch-server.scrbl
@@ -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?]
diff --git a/collects/web-server/scribblings/launch.scrbl b/collects/web-server/scribblings/launch.scrbl
index 981b34ae6a..aa23b73f5e 100644
--- a/collects/web-server/scribblings/launch.scrbl
+++ b/collects/web-server/scribblings/launch.scrbl
@@ -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]
diff --git a/collects/web-server/servlet-dispatch.rkt b/collects/web-server/servlet-dispatch.rkt
index 45e5125522..d41553313b 100644
--- a/collects/web-server/servlet-dispatch.rkt
+++ b/collects/web-server/servlet-dispatch.rkt
@@ -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))))))
diff --git a/collects/web-server/web-server.rkt b/collects/web-server/web-server.rkt
index 904bf1414d..fe18583cf3 100644
--- a/collects/web-server/web-server.rkt
+++ b/collects/web-server/web-server.rkt
@@ -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