fixed problem with PLaneT docs

svn: r3314

collects/help/private/config.ss

@@ -2,6 +2,7 @@
   (require (lib "file.ss")
            (lib "configuration.ss" "web-server")
 	   (lib "dirs.ss" "setup")
+           (lib "config.ss" "planet")
            "internal-hp.ss")
   
   (provide config)
@@ -52,5 +53,5 @@
 	     (lambda (virtual-host dir)
 	       `(,virtual-host 
 		 ,(make-host-config dir)))
-	     (append doc-hosts collects-hosts)
+	     (cons planet-host (append doc-hosts collects-hosts))
-	     (append doc-dirs collects-dirs))))))))
+	     (cons (PLANET-DIR) (append doc-dirs collects-dirs)))))))))

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

@@ -5,6 +5,7 @@
            "internal-hp.ss"
            (lib "contract.ss")
            (lib "etc.ss")
+	   (lib "config.ss" "planet")
            (lib "dirs.ss" "setup"))
   
   (provide/contract (get-help-url
@@ -30,7 +31,8 @@
 		=>
 		(λ (l-o-path)
                   ((cadr candidate) l-o-path anchor))]
-	       [else (loop (cdr candidates))]))])))))
+	       [else
+                (loop (cdr candidates))]))])))))
 
   (define manual-path-candidates '())
   (define (maybe-add-candidate candidate host)
@@ -49,8 +51,8 @@
 		  manual-path-candidates))))
 
   ;; Add doc dirs later, so that they take precedence:
-  (for-each (lambda (dir host)
+  (maybe-add-candidate (PLANET-DIR) planet-host)
-              (maybe-add-candidate dir host))
+  (for-each (λ (dir host) (maybe-add-candidate dir host))
             (append collects-dirs doc-dirs)
             (append collects-hosts doc-hosts))
   

collects/help/private/gui.ss

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

collects/help/private/internal-hp.ss

@@ -1,8 +1,11 @@
 (module internal-hp mzscheme
-  (require (lib "dirs.ss" "setup"))
+  (require (lib "dirs.ss" "setup")
-  (provide internal-port internal-host
+           (lib "config.ss" "planet"))
+  (provide internal-port 
+           is-internal-host? internal-host
 	   collects-hosts collects-dirs
-	   doc-hosts doc-dirs)
+	   doc-hosts doc-dirs
+           planet-host)
 
   ;; Hostnames defined here should not exist as real machines
 
@@ -20,6 +23,9 @@
   (define internal-host "helpdesk-internal.localhost")
   (define internal-port 8000)
 
+  (define (is-internal-host? str)
+    (member str all-internal-hosts))
+  
   (define (generate-hosts prefix dirs)
     (let loop ([dirs dirs][n 0])
       (if (null? dirs)
@@ -27,6 +33,8 @@
 	  (cons (format "~a~a.~a" prefix n internal-host)
 		(loop (cdr dirs) (add1 n))))))
 
+  (define planet-host (format "planet.~a" internal-host))
+  
   (define collects-dirs
     (get-collects-search-dirs))
   (define collects-hosts
@@ -35,4 +43,9 @@
   (define doc-dirs
     (get-doc-search-dirs))
   (define doc-hosts
-    (generate-hosts "doc" doc-dirs)))
+    (generate-hosts "doc" doc-dirs))
+  
+  (define all-internal-hosts 
+    (append (list internal-host planet-host)
+            collects-hosts
+            doc-hosts)))

collects/help/private/tcp-intercept.ss

@@ -29,24 +29,8 @@
     (unit/sig net:url^
       (import (raw : net:url^))
       
-      (define (url->string url)
+      (redefine url->string
-        (cond
+                get-pure-port
-          [(and (equal? (url-port url) internal-port)
-                (equal? (url-host url) internal-host))
-           (let* ([long
-                   (url->string 
-                    (make-url ""
-			      (url-user url)
-			      ""
-			      #f
-			      (url-path-absolute? url)
-                              (url-path url)
-			      (url-query url)
-			      (url-fragment url)))])
-             (substring long 3 (string-length long)))]
-          [else (raw:url->string url)]))
-      
-      (redefine get-pure-port
                 get-impure-port
                 post-pure-port
                 post-impure-port
@@ -107,9 +91,7 @@
       ; : (str nat -> iport oport) -> str nat -> iport oport
       (define (gen-tcp-connect raw)
         (lambda (hostname-string port)
-          (if (and (or (string=? internal-host hostname-string)
+          (if (and (is-internal-host? hostname-string)
-                       (ormap (lambda (host) string=? host hostname-string)
-			      doc-hosts))
                    (equal? internal-port port))
               (let-values ([(req-in req-out) (make-pipe)]
                            [(resp-in resp-out) (make-pipe)])

collects/lang/htdp-langs.ss

@@ -713,7 +713,7 @@ tracing todo:
 				 (send tab tracing:add-line (get-output-string sp))
 				 (semaphore-post sema))
 			       #f)))
-			  ;; Wait for th eline to get written, so that the
+			  ;; Wait for the line to get written, so that the
 			  ;;  trace output doesn't get too far behind (which
 			  ;;  matters, again, for infinite loops)
 			  (semaphore-wait sema)))))))))))

collects/setup/dirs.ss

@@ -117,8 +117,7 @@
   (define (get-doc-search-dirs)
     (combine-search (force config:doc-search-dirs)
 		    (append (get-new-doc-search-dirs)
-			    (map (lambda (p)
+			    (map (lambda (p) (build-path p "doc"))
-				   (build-path p "doc"))
 				 (current-library-collection-paths)))))
 
   ;; ----------------------------------------