abstracting

svn: r13467

collects/web-server/scribblings/servlet-env.scrbl

@@ -131,7 +131,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
  The server listens on @scheme[listen-ip] and port @scheme[port].
  
  If @scheme[ssl?] is true, then the server runs in HTTPS mode with @filepath{<server-root-path>/server-cert.pem}
- and @filepath{<server-root-path>/private-key.pem} as the certificates and private keys 
+ and @filepath{<server-root-path>/private-key.pem} as the certificates and private keys.
  
  The servlet is loaded with @scheme[manager]
  as its continuation manager. (The default manager limits the amount of memory to 64 MB and
@@ -181,4 +181,28 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
  The modules specified by @scheme[servlet-namespace] are shared with other servlets.
 }
                       
+@defproc[(serve/launch/wait
+          [make-dispatcher (semaphore? . -> . dispatcher/c)]
+          [#:launch-path launch-path (or/c false/c string?) #f]
+          [#:banner? banner? boolean? #f]
+          [#:listen-ip listen-ip (or/c false/c string?) "127.0.0.1"]
+          [#:port port number? 8000]
+          [#:ssl-keys ssl-keys (or/c false/c (cons/c path-string? path-string?)) #f])
+         void]{
+ The other interesting part of @scheme[serve/servlet] is its ability to start up a server and immediately
+ launch a browser at it. This is provided by @scheme[serve/launch/wait].
+ 
+ It starts a server using the result of @scheme[make-dispatcher] as the dispatcher. @scheme[make-dispatcher] is supplied
+ a semaphore that if posted, will cause the server to quit.
+ 
+ If @scheme[launch-path] is not false, then a browser is launch with that path appended to the URL to the server itself.
+ 
+ If @scheme[banner?] is true, then a banner is printed informing the user of the server's URL.
+ 
+ The server listens on @scheme[listen-ip] and port @scheme[port].
+ 
+ If @scheme[ssl-keys] is not false, then the server runs in HTTPS mode with @scheme[(car ssl-keys)]
+ and @scheme[(cdr ssl-keys)] as paths to the certificate and private key.    
+}
+              
 }

collects/web-server/servlet-env.ss

@@ -51,6 +51,14 @@
                      #: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-keys (or/c false/c (cons/c path-string? path-string?)))
+                     . ->* .
+                     void)]
  [serve/servlet (((request? . -> . response/c))
                  (#:command-line? boolean?
                   #:launch-browser? boolean?
@@ -120,6 +128,56 @@
             (set-box! servlet-box servlet)
             servlet))))))
 
+(define (serve/launch/wait
+         dispatcher
+         
+         #:launch-path
+         [launch-path #f]          
+         #:banner?
+         [banner? #t]
+         
+         #:listen-ip
+         [listen-ip "127.0.0.1"]
+         #:port
+         [port 8000]
+         #:ssl-keys
+         [ssl-keys #f])
+  (define ssl? (pair? ssl-keys))
+  (define server-url
+    (string-append (if ssl? "https" "http")
+                   "://localhost"
+                   (if (and (not ssl?) (= port 80))
+                     "" (format ":~a" port))))
+  (define sema (make-semaphore 0))
+  (define shutdown-server
+    (serve #:dispatch (dispatcher sema)
+           #:listen-ip listen-ip
+           #:port port
+           #:tcp@ (if ssl?
+                    (let ()
+                      (define-unit-binding ssl-tcp@
+                        (make-ssl-tcp@
+                         (car ssl-keys) (cdr ssl-keys)
+                         #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)
+      ;; We can get here if a /quit url is visited
+      (bye))))
+
 (define (serve/servlet
          start
          #:command-line?
@@ -177,16 +235,7 @@
          [log-file #f]
          #:log-format
          [log-format 'apache-default])
-  (define standalone-url
+  (define (dispatcher sema)
-    (string-append (if ssl? "https" "http")
-                   "://localhost"
-                   (if (and (not ssl?) (= the-port 80))
-                     "" (format ":~a" the-port))
-                   servlet-path))
-  (define make-servlet-namespace
-    (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace))
-  (define sema (make-semaphore 0))
-  (define dispatcher
     (dispatcher-sequence
      (and log-file (log:make #:format (log:log-format->format log-format)
                              #:log-path log-file))
@@ -205,7 +254,8 @@
                      (fsmap:make-url->valid-path
                       (fsmap:make-url->path servlets-root)))
                     (make-default-path->servlet
-                     #:make-servlet-namespace make-servlet-namespace))])
+                     #:make-servlet-namespace 
+                     (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)))])
        (servlets:make url->servlet))
      (map (lambda (extra-files-path)
             (files:make
@@ -218,29 +268,14 @@
       #:path->mime-type (make-path->mime-type mime-types-path)
       #:indices (list "index.html" "index.htm"))
      (lift:make file-not-found-responder)))
-  (define shutdown-server
+  (serve/launch/wait
-    (serve #:dispatch dispatcher
+   dispatcher   
-           #:listen-ip listen-ip
+   #:launch-path (if launch-browser? servlet-path #f) 
-           #:port the-port
+   #:banner? banner?   
-           #:tcp@ (if ssl?
+   #:listen-ip listen-ip
-                    (let ()
+   #:port the-port
-                      (define-unit-binding ssl-tcp@
+   #:ssl-keys
-                        (make-ssl-tcp@
+   (if ssl?
-                         (build-path server-root-path "server-cert.pem")
+       (cons (build-path server-root-path "server-cert.pem")
-                         (build-path server-root-path "private-key.pem")
+             (build-path server-root-path "private-key.pem"))
-                         #f #f #f #f #f)
+       #f)))
-                        (import) (export tcp^))
-                      ssl-tcp@)
-                    tcp@)))
-  (when launch-browser?
-    ((send-url) standalone-url #t))
-  (when banner?
-    (printf "Your Web application is running at ~a.\n" standalone-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)
-      ;; We can get here if a /quit url is visited
-      (bye))))