diff --git a/collects/help/private/config.ss b/collects/help/private/config.ss index 26f9685274..52c3cbef3b 100644 --- a/collects/help/private/config.ss +++ b/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) - (append doc-dirs collects-dirs)))))))) + (cons planet-host (append doc-hosts collects-hosts)) + (cons (PLANET-DIR) (append doc-dirs collects-dirs))))))))) diff --git a/collects/help/private/get-help-url.ss b/collects/help/private/get-help-url.ss index 5ccca44c2d..379bce1dd3 100644 --- a/collects/help/private/get-help-url.ss +++ b/collects/help/private/get-help-url.ss @@ -5,7 +5,8 @@ "internal-hp.ss" (lib "contract.ss") (lib "etc.ss") - (lib "dirs.ss" "setup")) + (lib "config.ss" "planet") + (lib "dirs.ss" "setup")) (provide/contract (get-help-url (opt-> @@ -25,12 +26,13 @@ [(null? candidates) "/cannot-find-docs.html"] [else (let ([candidate (car candidates)]) - (cond + (cond [(subpath/tail (car candidate) segments) => (λ (l-o-path) - ((cadr candidate) l-o-path anchor))] - [else (loop (cdr candidates))]))]))))) + ((cadr candidate) l-o-path anchor))] + [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 dir host)) + (maybe-add-candidate (PLANET-DIR) planet-host) + (for-each (λ (dir host) (maybe-add-candidate dir host)) (append collects-dirs doc-dirs) (append collects-hosts doc-hosts)) diff --git a/collects/help/private/gui.ss b/collects/help/private/gui.ss index 05a614fa62..3a3f0c8a68 100644 --- a/collects/help/private/gui.ss +++ b/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)) - (ormap (lambda (host) - (equal? host (url-host url))) - collects-hosts))) + (is-internal-host? (url-host url))) 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) diff --git a/collects/help/private/internal-hp.ss b/collects/help/private/internal-hp.ss index 34ef392324..1404a8191a 100644 --- a/collects/help/private/internal-hp.ss +++ b/collects/help/private/internal-hp.ss @@ -1,8 +1,11 @@ (module internal-hp mzscheme - (require (lib "dirs.ss" "setup")) - (provide internal-port internal-host + (require (lib "dirs.ss" "setup") + (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))) diff --git a/collects/help/private/tcp-intercept.ss b/collects/help/private/tcp-intercept.ss index b15a4b6646..3c8bbe30da 100644 --- a/collects/help/private/tcp-intercept.ss +++ b/collects/help/private/tcp-intercept.ss @@ -29,24 +29,8 @@ (unit/sig net:url^ (import (raw : net:url^)) - (define (url->string url) - (cond - [(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 + (redefine url->string + 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) - (ormap (lambda (host) string=? host hostname-string) - doc-hosts)) + (if (and (is-internal-host? hostname-string) (equal? internal-port port)) (let-values ([(req-in req-out) (make-pipe)] [(resp-in resp-out) (make-pipe)]) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index f88d5d2578..0e74c501c8 100644 --- a/collects/lang/htdp-langs.ss +++ b/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))))))))))) diff --git a/collects/setup/dirs.ss b/collects/setup/dirs.ss index 2898d680d0..553f707afc 100644 --- a/collects/setup/dirs.ss +++ b/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) - (build-path p "doc")) + (map (lambda (p) (build-path p "doc")) (current-library-collection-paths))))) ;; ----------------------------------------