suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed problem with PLaneT docs

Browse Source 
svn: r3314
This commit is contained in:
Robby Findler 2006-06-10 03:30:23 +00:00
parent 77e2fee4ef
commit e57077cc7c
7 changed files with 35 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/help/private/config.ss
View File

@ -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)))))))))

14
collects/help/private/get-help-url.ss
View File

@ -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))

7
collects/help/private/gui.ss
View File

@ -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)

21
collects/help/private/internal-hp.ss
View File

@ -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)))

24
collects/help/private/tcp-intercept.ss
View File

@ -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)])

2
collects/lang/htdp-langs.ss
View File

@ -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)))))))))))

3
collects/setup/dirs.ss
View File

@ -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)))))
;; ----------------------------------------