make a launcher for standalone help-desk server, option for port number to listen on

svn: r7174

collects/help/help-desk-server.ss

@@ -1,4 +1,4 @@
-;;; launch.ss
+(module help-desk-server mzscheme
 
 ;; PURPOSE
 ;;   This file launches a web-server serving an online
@@ -8,23 +8,33 @@
 
 ;; NOTES
 ;;   The web-server uses the port given by internal-port
-;;   in "collects/help/private/internal-hp.ss".
+;;   in "private/options.ss" by default.
+
+;; Startpage:
+;;   http://localhost:8012/servlets/home.ss
+;;   (where 8012 is the port given by internal-port)
 
-;;  Startpage:
-;;     http://localhost:8000/servlets/home.ss
-;;     (where 8000 is the port given by internal-port)
 
 (require (lib "web-server.ss" "web-server")
          (lib "web-config-unit.ss" "web-server")
          "private/config.ss"
-         (only "private/internal-hp.ss" internal-host)
+         "private/internal-hp.ss"
-         "private/options.ss")
+         "private/options.ss"
+         (lib "cmdline.ss"))
 
 (helpdesk-platform 'external-browser)
 
+(command-line
+ "help-desk-server"
+ (current-command-line-arguments)
+ (once-each
+  [("-p" "--port") port "port to run on"
+   (internal-port (string->number port))]))
+(printf "launch>>>> ~s\n" (internal-port))
+
 ;; start the HelpDesk server, and store a shutdown
 (define shutdown
-  (serve/web-config@ config))
+  (serve/web-config@ (make-config)))
 
 (printf "\nStart here: http://~a:~a/servlets/home.ss\n\n"
         internal-host (internal-port))
@@ -32,3 +42,5 @@
 (printf "Press enter to shutdown.\n")
 (read-line)
 ;(shutdown)
+
+)

collects/help/info.ss

@@ -2,7 +2,7 @@
 (module info (lib "infotab.ss" "setup")
   (define name "Help")
   (define doc.txt "doc.txt")
-  (define compile-subcollections 
+  (define compile-subcollections
     '(("help" "private")
       ("help" "servlets")
       ("help" "servlets" "private")
@@ -13,7 +13,9 @@
       ("help" "servlets" "scheme" "misc")))
   (define help-desk-message
     "Mr: (require (lib \"help-desk.ss\" \"help\"))")
-  (define mred-launcher-libraries (list "help.ss"))
+  (define mred-launcher-libraries '("help.ss"))
-  (define mred-launcher-names (list "Help Desk"))
+  (define mred-launcher-names     '("Help Desk"))
+  (define mzscheme-launcher-libraries '("help-desk-server.ss"))
+  (define mzscheme-launcher-names     '("Help Desk Server"))
   (define install-collection "installer.ss")
   (define compile-omit-files '("launch.ss")))

collects/help/private/config.ss

@@ -6,9 +6,9 @@
            "internal-hp.ss"
            (lib "namespace.ss" "web-server" "configuration"))
   
-  (provide config)
+  (provide make-config)
   
-  (define config
+  (define (make-config)
     (let* ([build-normal-path
             (lambda args
               (normalize-path
@@ -44,7 +44,7 @@
                  (mime-types "../../web-server/default-web-root/mime.types")
                  (password-authentication "passwords"))))])
       (configuration-table-sexpr->web-config@
-       `((port ,internal-port)
+       `((port ,(internal-port))
          (max-waiting 40)
          (initial-connection-timeout 30)
          (default-host-table

collects/help/private/get-help-url.ss

@@ -36,7 +36,7 @@
                         (λ (segments anchor)
 			  (format "http://~a:~a/servlets/static.ss/~a~a~a"
 				  internal-host
-				  internal-port
+				  (internal-port)
                                   host
                                   (apply string-append (map (λ (x) (format "/~a" (path->string x))) 
 					                    segments))

collects/help/private/gui.ss

@@ -111,7 +111,7 @@
                       url]
                      
                      ;; one of the "collects" hosts:
-                     [(and (equal? internal-port (url-port url))
+                     [(and (equal? (internal-port) (url-port url))
                            (ormap (lambda (host)
 				    (equal? host (url-host url)))
 				  doc-hosts))
@@ -160,7 +160,7 @@
 			    url))]
 
 		     ;; one of the other internal hosts
-                     [(and (equal? internal-port (url-port url))
+                     [(and (equal? (internal-port) (url-port url))
 			   (is-internal-host? (url-host url)))
 		      url]
                      
@@ -194,7 +194,7 @@
             (mixin (hyper-text<%> editor<%>) ()
               (define/augment (url-allows-evaling? url)
                 (and (is-internal-host? (url-host url))
-                     (equal? internal-port (url-port url))))
+                     (equal? (internal-port) (url-port url))))
               
               (define show-sk? #t)
               

collects/help/private/internal-hp.ss

@@ -2,7 +2,7 @@
   (require (lib "dirs.ss" "setup")
            (lib "config.ss" "planet")
            "options.ss")
-  (provide (rename internal-port* internal-port)
+  (provide internal-port
            is-internal-host? internal-host
 	   collects-hosts collects-dirs
 	   doc-hosts doc-dirs
@@ -25,11 +25,6 @@
   ;;  URLs.)
 
   (define internal-host "localhost")
-  ;; fake an internal-port binding (actually a parameter in options.ss)
-  (define-syntax internal-port*
-    (syntax-id-rules ()
-      [(x . xs) ((internal-port) . xs)]
-      [x (internal-port)]))
 
   (define (is-internal-host? str)
     (member str all-internal-hosts))

collects/help/private/link.ss

@@ -27,7 +27,7 @@
   
   (define-unit-from-context inst@ setup:plt-installer^)
   (define-unit-from-context real-tcp@ tcp^)
-  (define-unit-binding config@ config (import) (export web-config^))
+  (define-unit-binding config@ (make-config) (import) (export web-config^))
   
   (define-compound-unit/infer help-desk@
     (import)

collects/help/private/standard-urls.ss

@@ -27,21 +27,21 @@
     (format "~a/html/~a/index.htm" (base-docs-url) manual-name))
 
   (define (prefix-with-server suffix)
-    (format "http://~a:~a~a" internal-host internal-port suffix))
+    (format "http://~a:~a~a" internal-host (internal-port) suffix))
   
-  (define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host internal-port))
+  (define results-url-prefix (format "http://~a:~a/servlets/results.ss?" internal-host (internal-port)))
   (define flush-manuals-path "/servlets/results.ss?flush=yes")
-  (define flush-manuals-url (format "http://~a:~a~a" internal-host internal-port flush-manuals-path))
+  (define flush-manuals-url (format "http://~a:~a~a" internal-host (internal-port) flush-manuals-path))
   
   
   (define relative-results-url-prefix "/servlets/results.ss?")
 
-  (define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host internal-port))
+  (define home-page-url (format "http://~a:~a/servlets/home.ss" internal-host (internal-port)))
   
   (define (make-missing-manual-url coll name link)
     (format "http://~a:~a/servlets/missing-manual.ss?manual=~a&name=~a&link=~a"
             internal-host
-            internal-port
+            (internal-port)
             coll
             (uri-encode name)
             (uri-encode link)))

collects/help/private/tcp-intercept.ss

@@ -96,7 +96,7 @@
       (define (gen-tcp-connect raw)
         (lambda (hostname-string port)
           (if (and (is-internal-host? hostname-string)
-                   (equal? internal-port port))
+                   (equal? (internal-port) port))
               (let-values ([(req-in req-out) (make-pipe)]
                            [(resp-in resp-out) (make-pipe)])
                 (parameterize ([current-custodian (make-custodian)])

collects/help/servlets/private/url.ss

@@ -4,8 +4,7 @@
   (provide (all-defined))
   
   (define url-helpdesk-root
-    (string-append
+    (format "http://~a:~a/servlets/" internal-host (internal-port)))
-     "http://" internal-host ":" (number->string internal-port) "/servlets/"))
   
   (define url-helpdesk-home    (string-append url-helpdesk-root "home.ss"))
   (define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
@@ -65,4 +64,4 @@
   (define url-helpdesk-tour                 (url-home-subpage "tour"))
   (define url-helpdesk-why-drscheme         (url-home-subpage "why-drscheme"))
 
-  )
+  )