Update run program

svn: r6447

collects/web-server/run.ss

@@ -1,5 +1,7 @@
 (module run mzscheme
-  (require (lib "web-server.ss" "web-server")
+  (require (lib "cmdline.ss")
+           (lib "file.ss")
+           (lib "web-server.ss" "web-server")
            (lib "responders.ss" "web-server" "configuration")
            (prefix fsmap: (lib "filesystem-map.ss" "web-server" "dispatchers"))
            (prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
@@ -8,27 +10,43 @@
            (prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers"))
            (prefix lang: (lib "dispatch-lang.ss" "web-server" "dispatchers")))
   
-  (define server-root-path (build-path "~" "Development" "plt" "default-web-root"))
-  (define default-host-path (build-path server-root-path "conf"))  
+  (define server-root-path (make-parameter (collection-path "web-server" "default-web-root")))
+  (define port (make-parameter 8080))
+  
+  (parse-command-line 
+   "run" (current-command-line-arguments)
+   `((once-each
+      [("-p" "--port") 
+       ,(lambda (flag the-port) (port (string->number the-port)))
+       (,(format "Specify a different port (default: ~a)" (number->string (port)))
+        "number")]
+      [("-r" "--root") 
+       ,(lambda (flag path) (server-root-path (normalize-path (string->path path))))
+       (,(format "Specify a different server root path (default: ~a)" (path->string (server-root-path)))
+        "path")]))
+   (lambda (flag-accum) (void))
+   null)
+  
+  (define default-host-path (build-path (server-root-path) "conf"))  
   (define file-not-found-file (build-path default-host-path "not-found.html"))
   (define servlet-error-file (build-path default-host-path "servlet-error.html"))
   
   (define url->path
     (fsmap:make-url->path 
-     (build-path server-root-path "htdocs")))
+     (build-path (server-root-path) "htdocs")))
   
-  (serve
-   #:port 8080
-   #:dispatch (sequencer:make
-               (filter:make
-                #rx"\\.ss"
-                (lang:make #:url->path (fsmap:make-url->path/optimism url->path)
-                           #:timeouts-servlet-connection 86400
-                           #:responders-servlet-loading (gen-servlet-responder servlet-error-file)
-                           #:responders-servlet (gen-servlet-responder servlet-error-file)))
-               (files:make #:url->path url->path
-                           #:mime-types-path (build-path server-root-path "mime.types")
-                           #:indices (list "index.html" "index.htm"))
-               (const:make (gen-file-not-found-responder file-not-found-file))))
+  (serve #:port (port)
+         #:dispatch
+         (sequencer:make
+          (filter:make
+           #rx"\\.ss"
+           (lang:make #:url->path (fsmap:make-url->path/optimism url->path)
+                      #:timeouts-servlet-connection 86400
+                      #:responders-servlet-loading (gen-servlet-responder servlet-error-file)
+                      #:responders-servlet (gen-servlet-responder servlet-error-file)))
+          (files:make #:url->path url->path
+                      #:mime-types-path (build-path (server-root-path) "mime.types")
+                      #:indices (list "index.html" "index.htm"))
+          (const:make (gen-file-not-found-responder file-not-found-file))))
   
   (do-not-return))

collects/web-server/web-server.ss

@@ -11,10 +11,9 @@
            "web-server-sig.ss"
            "web-server-unit.ss"
            (prefix http: "private/request.ss"))
-  (provide
-   serve
-   serve/ports
-   serve/ips+ports)
+  (provide serve
+           serve/ports
+           serve/ips+ports)
   (provide/contract
    [do-not-return (-> void)]
    [serve/web-config@ (unit? . -> . (-> void?))])