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

oops. Added things back so that drscheme works

Browse Source 
svn: r7780
This commit is contained in:
Robby Findler 2007-11-20 04:31:58 +00:00
parent 351937e933
commit 0e5aa22a9d
18 changed files with 1652 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drscheme/private/drsig.ss
View File

@ -200,9 +200,7 @@
goto-release-notes
goto-plt-license
help-desk
get-docs
open-url
add-help-desk-font-prefs))
get-docs))
(define-signature drscheme:language^
(get-default-mixin

120
collects/drscheme/private/help-desk.ss
View File

@ -3,7 +3,8 @@
(require (lib "string-constant.ss" "string-constants")
(lib "mred.ss" "mred")
(lib "external.ss" "browser")
(lib "help-desk.ss" "help")
(lib "bug-report.ss" "help")
(lib "buginfo.ss" "help" "private")
(lib "framework.ss" "framework")
(lib "class.ss")
(lib "list.ss")
@ -13,10 +14,9 @@
(import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^])
(export (rename drscheme:help-desk^
[-add-help-desk-font-prefs add-help-desk-font-prefs]))
(export drscheme:help-desk^)
(define (-add-help-desk-font-prefs b) (add-help-desk-font-prefs b))
(define (-add-help-desk-font-prefs b) '(add-help-desk-font-prefs b))
;; : -> string
(define (get-computer-language-info)
@ -32,88 +32,8 @@
(send language get-language-position)
(send language marshall-settings settings)))))
;; get-docs : (listof (cons path[short-dir-name] string[doc full name]))
(define (get-docs)
(let ([dirs (find-doc-names)])
(map (λ (pr)
(let-values ([(base name dir?) (split-path (car pr))])
(cons name (cdr pr))))
dirs)))
(set-bug-report-info! "Computer Language" get-computer-language-info)
(define drscheme-help-desk-mixin
(mixin (help-desk-frame<%> frame:standard-menus<%>) ()
(define/override (file-menu:create-open-recent?) #t)
(define/override (file-menu:new-callback x y)
(handler:edit-file #f)
#t)
(define/override (file-menu:between-save-as-and-print menu)
(new separator-menu-item% (parent menu)))
(define current-language
(preferences:get drscheme:language-configuration:settings-preferences-symbol))
(define/public (set-current-language cl)
(set! current-language cl))
(define/override (order-manuals x)
(send (drscheme:language-configuration:language-settings-language current-language)
order-manuals
x))
(define/override (get-language-name)
(send (drscheme:language-configuration:language-settings-language current-language)
get-language-name))
(define/override (file-menu:between-new-and-open file-menu)
(instantiate menu:can-restore-menu-item% ()
(label (string-constant plt:hd:new-help-desk))
(parent file-menu)
(callback (λ (x y) (new-help-desk))))
(super file-menu:between-new-and-open file-menu))
(super-new)
(inherit get-menu-bar)
(inherit-field choices-panel)
(letrec ([language-menu (new menu%
(parent (get-menu-bar))
(label (string-constant language-menu-name)))]
[change-language-callback
(λ ()
(let ([new-settings (drscheme:language-configuration:language-dialog
#f
current-language
this
#t)])
(when new-settings
(set! current-language new-settings)
(send lang-message set-msg (get-language-name))
(preferences:set
drscheme:language-configuration:settings-preferences-symbol
new-settings))))]
[lang-message
(new lang-message%
(button-release (λ () (change-language-callback)))
(parent choices-panel)
(font normal-control-font))]
[language-item (new menu-item%
(label (string-constant choose-language-menu-item-label))
(parent language-menu)
(shortcut #\l)
(callback
(λ (x y)
(change-language-callback))))])
(frame:reorder-menus this)
(send lang-message set-msg (get-language-name))
;; move the grow box spacer pane to the end
(send choices-panel change-children
(λ (l)
(append
(filter (λ (x) (not (is-a? x grow-box-spacer-pane%))) l)
(list (car (filter (λ (x) (is-a? x grow-box-spacer-pane%)) l)))))))))
(define lang-message%
(class canvas%
(init-field button-release font)
@ -145,40 +65,22 @@
(send dc draw-text dots (- cw dw) (- (/ ch 2) (/ th 2)))]))))
(super-new)))
(define (goto-manual-link a b) (error 'goto-maual-link "~s ~s" a b))
(define (goto-hd-location b) (error 'goto-hd-location "~s" b))
(define (goto-help manual link) (goto-manual-link manual link))
(define (goto-tour) (goto-hd-location 'hd-tour))
(define (goto-release-notes) (goto-hd-location 'release-notes))
(define (goto-plt-license) (goto-hd-location 'plt-license))
(define (get-docs) (error 'help-desk.ss "get-docs"))
(define help-desk
(case-lambda
[() (show-help-desk)]
[() (void)]
[(key) (help-desk key #f)]
[(key lucky?) (help-desk key lucky? 'keyword+index)]
[(key lucky? type) (help-desk key lucky? type 'contains)]
[(key lucky? type mode) (help-desk key lucky? type mode #f)]
[(key lucky? type mode language)
(let ([frame (or (find-help-desk-frame)
(new-help-desk))])
(when language
(send frame set-current-language language))
(search-for-docs/in-frame
frame
key
(case type
[(keyword) "keyword"]
[(keyword+index) "keyword-index"]
[(keyword+index+text) "keyword-index-text"]
[else (error 'drscheme:help-desk:help-desk "unknown type argument: ~s" type)])
(case mode
[(exact) "exact-match"]
[(contains) "containing-match"]
[(regexp) "regexp-match"]
[else (error 'drscheme:help-desk:help-desk "unknown mode argument: ~s" mode)])
lucky?
(map car (get-docs))))]))
;; open-url : string -> void
(define (open-url x) (send-url x))
(add-help-desk-mixin drscheme-help-desk-mixin)
(void)]))

1
collects/drscheme/private/main.ss
View File

@ -204,7 +204,6 @@
list?)
(drscheme:font:setup-preferences)
(drscheme:help-desk:add-help-desk-font-prefs #t)
(color-prefs:add-background-preferences-panel)
(scheme:add-preferences-panel)
(scheme:add-coloring-preferences-panel)

6
collects/drscheme/private/tool-contracts.ss
View File

@ -1325,12 +1325,6 @@
; ;
; ;
(drscheme:help-desk:open-url
(string? . -> . void?)
(url)
"Opens \\var{url} in a new help desk window.")
(drscheme:help-desk:help-desk
(case->
(-> void?)

542
collects/help/bug-report.ss Normal file
View File

@ -0,0 +1,542 @@
(module bug-report mzscheme
(require (lib "string-constant.ss" "string-constants")
(lib "head.ss" "net")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "class.ss")
(lib "etc.ss")
(lib "list.ss")
(lib "url.ss" "net")
(lib "uri-codec.ss" "net")
(lib "htmltext.ss" "browser")
(lib "dirs.ss" "setup")
"private/buginfo.ss"
"private/manuals.ss")
(provide help-desk:report-bug)
(define bug-www-server "bugs.plt-scheme.org")
(define bug-www-server-port 80)
;; this one should be defined by help desk.
(define frame-mixin
(namespace-variable-value 'help-desk:frame-mixin #f (lambda () (lambda (x) x))))
(preferences:set-default 'drscheme:email "" string?)
(preferences:set-default 'drscheme:full-name "" string?)
(define bug-frame%
(class (frame-mixin (frame:standard-menus-mixin frame:basic%))
(init title)
;; a bunch of stuff we don't want
(define/override (file-menu:between-print-and-close menu) (void))
(define/override (edit-menu:between-find-and-preferences menu) (void))
(define/override (file-menu:create-open?) #f)
(define/override (file-menu:create-open-recent?) #f)
(define/override (file-menu:create-new?) #f)
(define/override (file-menu:create-save?) #f)
(define/override (file-menu:create-revert?) #f)
(field (ok-to-close? #f))
(public set-ok-to-close)
(define (set-ok-to-close ok?) (set! ok-to-close? #t))
(define/augment (can-close?)
(or ok-to-close?
(ask-yes-or-no (string-constant cancel-bug-report?)
(string-constant are-you-sure-cancel-bug-report?)
this)))
(super-make-object title)))
(define (help-desk:report-bug)
(define bug-frame (instantiate bug-frame% () (title (string-constant bug-report-form))))
(define single (new panel:single% (parent (send bug-frame get-area-container))))
(define outermost-panel (make-object vertical-panel% single))
(define response-panel (new vertical-panel% (parent single)))
(define response-text (new (html-text-mixin text%) (auto-wrap #t)))
(define response-ec (new editor-canvas% (parent response-panel) (editor response-text)))
(define response-button-panel (new horizontal-panel%
(stretchable-height #f)
(parent response-panel)
(alignment '(right center))))
(define cancel-kill-thread #f)
(define response-reset (new button%
(parent response-button-panel)
(enabled #f)
(label (string-constant dialog-back))
(callback
(lambda (x y)
(switch-to-compose-view)))))
(define response-abort (new button%
(parent response-button-panel)
(enabled #f)
(callback
(lambda (x y)
(kill-thread cancel-kill-thread)
(switch-to-compose-view)))
(label (string-constant abort))))
(define response-close (new button%
(parent response-button-panel)
(enabled #f)
(callback (lambda (x y) (cleanup-frame)))
(label (string-constant close))))
(define stupid-internal-define-syntax1
(new grow-box-spacer-pane% (parent response-button-panel)))
(define top-panel (make-object vertical-panel% outermost-panel))
(define (switch-to-response-view)
(send response-text lock #f)
(send response-text erase)
(render-html-to-text ; hack to get nice text in
(open-input-string
"&nbsp;<br><br><br><br><br><div align=\"center\"><h2><b>Submitting bug report...</b></h2></div>")
response-text #t #f)
(send response-text lock #t)
(send single active-child response-panel))
(define (switch-to-compose-view)
(send single active-child outermost-panel)
(send (if (string=? "" (preferences:get 'drscheme:full-name))
name
summary)
focus))
(define lps null)
; build/label : ((union string (list-of string))
; (area-container<%> -> item<%>)
; boolean
; area-container<%>
; -> item<%>)
; constructs and arranges the gui objects for the bug report form
; effect: updates lps with the new label panel, for future alignment
(define build/label
(opt-lambda (text make-item top? [stretch? #f] [top-panel top-panel] [vertical? #f])
(let*-values ([(hp) (make-object (if vertical?
vertical-panel%
horizontal-panel%)
top-panel)]
[(lp) (make-object vertical-panel% hp)]
[(ip) (make-object vertical-panel% hp)]
[(label/s) (if (string? text)
(make-object message% text lp)
(map (lambda (s)
(make-object message% s lp))
text))]
[(item) (make-item ip)])
(set! lps (cons lp lps))
(unless stretch?
(send hp stretchable-height #f)
(send lp stretchable-height #f)
(send ip stretchable-height #f))
(send lp stretchable-width #f)
(send lp stretchable-height #f)
(send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center))
(send ip set-alignment 'left 'top)
item)))
(define (align-labels)
(let ([width (apply max (map (lambda (x) (send (car (send x get-children)) min-width))
lps))])
(for-each (lambda (x) (send x min-width width)) lps)))
(define name
(build/label
(string-constant bug-report-field-name)
(lambda (panel)
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel
(lambda (text event)
(preferences:set 'drscheme:full-name (send text get-value)))
(preferences:get 'drscheme:full-name)))))
#f))
(define email
(build/label
(string-constant bug-report-field-email)
(lambda (panel)
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel
(lambda (text event)
(preferences:set 'drscheme:email (send text get-value)))
(preferences:get 'drscheme:email)))))
#f))
(define summary
(build/label
(string-constant bug-report-field-summary)
(lambda (panel)
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel void))))
#f))
(define severity
(build/label
(string-constant bug-report-field-severity)
(lambda (panel)
(make-object choice%
#f
(list "critical" "serious" "non-critical")
panel
void))
#f))
(define bug-classes '(("software bug" "sw-bug")
("documentation bug" "doc-bug")
("change request" "change-request")
("support" "support")))
(define bug-class
(build/label
(string-constant bug-report-field-class)
(lambda (panel)
(make-object choice%
#f
(map car bug-classes)
panel
void))
#f))
(define (translate-class class)
(cadr (assoc class bug-classes)))
(define (make-big-text label . args)
(let ([canvas
(apply
build/label
label
(lambda (panel)
(let* ([text (new (editor:standard-style-list-mixin
(editor:keymap-mixin
text:basic%)))]
[canvas (new canvas:basic%
(style '(hide-hscroll))
(parent panel)
(editor text))])
(send text set-paste-text-only #t)
(send text auto-wrap #t)
(send text set-styles-fixed #t)
canvas))
#t
args)])
(send canvas min-width 500)
(send canvas min-height 130)
(send canvas get-editor)
(send canvas allow-tab-exit #t)
canvas))
(define description (make-big-text (string-constant bug-report-field-description) #t))
(define reproduce (make-big-text (list (string-constant bug-report-field-reproduce1)
(string-constant bug-report-field-reproduce2))
#t))
(define synthesized-dialog (make-object dialog% (string-constant bug-report-synthesized-information)))
(define synthesized-panel (make-object vertical-panel% synthesized-dialog))
(define synthesized-button-panel
(new horizontal-panel% [parent synthesized-dialog]
[alignment '(right center)] [stretchable-height #f]))
(define synthesized-ok-button (make-object button% (string-constant ok) synthesized-button-panel
(lambda (x y)
(send synthesized-dialog show #f))))
(define synthesized-info-shown? #t)
(define (show-synthesized-info)
(send synthesized-dialog show #t))
(define version
(build/label
(string-constant bug-report-field-version)
(lambda (panel)
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel void ""))))
#f
#f
synthesized-panel
#f))
(define environment
(build/label
(string-constant bug-report-field-environment)
(lambda (panel)
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel void ""))))
#f
#f
synthesized-panel
#f))
(define human-language
(build/label
(string-constant bug-report-field-human-language)
(lambda (panel)
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel void ""))))
#f
#f
synthesized-panel))
(define memory-use
(build/label
(string-constant bug-report-field-memory-use)
(lambda (panel)
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel void ""))))
#f
#f
synthesized-panel))
(define docs-installed
(make-big-text
(string-constant bug-report-field-docs-installed)
#t
synthesized-panel))
(define collections
(make-big-text
(string-constant bug-report-field-collections)
#t
synthesized-panel))
(define extras
(map (lambda (bri)
(let ([label (bri-label bri)])
(cons
label
(build/label
label
(lambda (panel)
(let ([field
(keymap:call/text-keymap-initializer
(lambda ()
(make-object text-field% #f panel void "")))])
(send field set-value (bri-value bri))
field))
#f
#f
synthesized-panel))))
(get-bug-report-infos)))
(define button-panel
(new horizontal-panel% [parent outermost-panel]
[alignment '(right center)] [stretchable-height #f]))
(define synthesized-button (make-object button%
(string-constant bug-report-show-synthesized-info)
button-panel (lambda x (show-synthesized-info))))
(define _spacer (new horizontal-pane% (parent button-panel)))
(define cancel-button (make-object button% (string-constant cancel) button-panel (lambda x (cancel))))
(define ok-button (make-object button% (string-constant bug-report-submit) button-panel (lambda x (ok))))
(define _grow-box
(new grow-box-spacer-pane% [parent button-panel]))
(define (get-query)
(list (cons 'help-desk "true")
(cons 'replyto (preferences:get 'drscheme:email))
(cons 'originator (preferences:get 'drscheme:full-name))
(cons 'subject (send summary get-value))
(cons 'severity (send severity get-string-selection))
(cons 'class (translate-class (send bug-class get-string-selection)))
(cons 'release (send version get-value))
(cons 'description (apply string-append (map (lambda (x) (string-append x "\n"))
(get-strings description))))
(cons 'how-to-repeat (apply string-append
(map (lambda (x) (string-append x "\n"))
(get-strings reproduce))))
(cons 'platform (get-environment))))
(define (get-environment)
(string-append (send environment get-value)
"\n"
"Docs Installed:\n"
(format "~a" (send (send docs-installed get-editor) get-text))
"\n"
(format "Human Language: ~a\n" (send human-language get-value))
(format "(current-memory-use) ~a\n" (send memory-use get-value))
"\nCollections:\n"
(format "~a" (send (send collections get-editor) get-text))
"\n"
(apply
string-append
(map (lambda (extra)
(format "~a: ~a\n"
(car extra)
(send (cdr extra) get-value)))
extras))))
; send-bug-report : (-> void)
;; initiates sending the bug report and switches the GUI's mode
(define (send-bug-report)
(letrec ([query (get-query)]
[url
(string->url (format "http://~a:~a/cgi-bin/bug-report"
bug-www-server
bug-www-server-port))]
[post-data
(parameterize ([current-alist-separator-mode 'amp])
(string->bytes/utf-8 (alist->form-urlencoded query)))]
[http-thread
(parameterize ([current-custodian (make-custodian)])
(thread
(lambda ()
(with-handlers ([(lambda (x) (exn:break? x))
(lambda (x) (void))]
[(lambda (x) (not (exn:break? x)))
(lambda (x)
(queue-callback
(lambda ()
(switch-to-compose-view)
(message-box
(string-constant error-sending-bug-report)
(format (string-constant error-sending-bug-report-expln)
(if (exn? x)
(exn-message x)
(format "~s" x)))))))])
(parameterize ([current-alist-separator-mode 'amp])
(call/input-url
url
(case-lambda
[(x) (post-pure-port x post-data)]
[(x y) (post-pure-port x post-data y)])
(lambda (port)
(send response-text lock #f)
(send response-text erase)
(render-html-to-text port response-text #t #f)
(send response-text lock #t))))
(queue-callback
(lambda ()
(send response-abort enable #f)
(send response-reset enable #t)
(send response-close enable #t)
(set! cancel-kill-thread #f)
(send bug-frame set-ok-to-close #t)
(send response-close focus)))))))])
(set! cancel-kill-thread http-thread)
(send response-abort enable #t)
(switch-to-response-view)))
(define (get-strings canvas)
(let ([t (send canvas get-editor)])
(let loop ([n 0])
(cond
[(> n (send t last-paragraph)) null]
[else (cons (send t get-text
(send t paragraph-start-position n)
(send t paragraph-end-position n))
(loop (+ n 1)))]))))
(define (sanity-checking)
(let ([no-value?
(lambda (f)
(cond
[(is-a? f editor-canvas%)
(= 0 (send (send f get-editor) last-position))]
[else (string=? "" (send f get-value))]))])
(let/ec done-checking
(for-each
(lambda (field field-name)
(when (no-value? field)
(message-box (string-constant illegal-bug-report)
(format (string-constant pls-fill-in-field) field-name))
(done-checking #f)))
(list name summary)
(list (string-constant bug-report-field-name)
(string-constant bug-report-field-summary)))
(when (and (no-value? description)
(no-value? reproduce))
(message-box (string-constant illegal-bug-report)
(string-constant pls-fill-in-either-description-or-reproduce))
(done-checking #f))
(unless (regexp-match #rx"@" (or (preferences:get 'drscheme:email) ""))
(message-box (string-constant illegal-bug-report)
(string-constant malformed-email-address))
(done-checking #f))
(done-checking #t))))
(define (ok)
(when (sanity-checking)
(send-bug-report)))
(define (cancel)
(cleanup-frame))
(define (cleanup-frame)
(send bug-frame close))
(define (directories-contents dirs)
(map (lambda (d)
(cons (path->string d)
(if (directory-exists? d)
(map path->string (directory-list d))
'(non-existent-path))))
dirs))
(define (split-by-directories dirs split-by)
(let ([res (append (map list (map path->string split-by)) '((*)))]
[dirs (map path->string dirs)])
(for-each
(lambda (d)
(let* ([l (string-length d)]
[x (assf
(lambda (d2)
(or (eq? d2 '*)
(let ([l2 (string-length d2)])
(and (< l2 l) (equal? d2 (substring d 0 l2))
(member (string-ref d l2) '(#\/ #\\))))))
res)])
(append x (list (if (string? (car x))
(substring d (add1 (string-length (car x))))
d)))))
dirs)
(filter (lambda (x) (pair? (cdr x))) res)))
(send response-ec allow-tab-exit #t)
(send severity set-selection 1)
(send version set-value (format "~a" (version:version)))
(send environment set-value
(format "~a ~s (~a) (get-display-depth) = ~a"
(system-type)
(system-type 'machine)
(system-library-subpath)
(get-display-depth)))
(send (send collections get-editor)
insert
(format "~s" (directories-contents (get-collects-search-dirs))))
(send human-language set-value (format "~a" (this-language)))
(send memory-use set-value (format "~a" (current-memory-use)))
(send (send collections get-editor) auto-wrap #t)
(send (send docs-installed get-editor) auto-wrap #t)
;; Currently, the help-menu is left empty
(frame:remove-empty-menus bug-frame)
(align-labels)
(switch-to-compose-view)
(send (send docs-installed get-editor) insert
(format "~s" (split-by-directories (find-doc-directories)
(get-doc-search-dirs))))
(send bug-frame show #t))
(define (ask-yes-or-no title msg parent)
(gui-utils:get-choice msg
(string-constant yes)
(string-constant no)
title
#f
parent)))

3
collects/help/help-desk-urls.ss Normal file
View File

@ -0,0 +1,3 @@
(module help-desk-urls mzscheme
(require "servlets/private/url.ss")
(provide (all-from "servlets/private/url.ss")))

21
collects/help/private/buginfo.ss Normal file
View File

@ -0,0 +1,21 @@
(module buginfo mzscheme
(provide set-bug-report-info!
get-bug-report-infos
bri-label
bri-value)
(define-struct bri (label get-value))
(define (bri-value bri) ((bri-get-value bri)))
; update with symbol/string assoc list
(define bug-report-infos null)
(define (set-bug-report-info! str thunk)
(set! bug-report-infos (cons (make-bri str thunk) bug-report-infos)))
(define (get-bug-report-infos) bug-report-infos))

65
collects/help/private/colldocs.ss Normal file
View File

@ -0,0 +1,65 @@
(module colldocs mzscheme
(require (lib "list.ss")
(lib "getinfo.ss" "setup")
(lib "contract.ss"))
;; find-doc-directory-records : -> (list-of directory-record)
;; Returns directory records containing doc.txt files, sorted first
;; by lib/planet, then by path.
(define (find-doc-directory-records)
(define allrecs
(find-relevant-directory-records '(doc.txt) 'all-available))
(define (rec<? a b)
(bytes<? (path->bytes (directory-record-path a))
(path->bytes (directory-record-path b))))
(define (librec? dirrec)
(let ([spec (directory-record-spec dirrec)])
(and (pair? spec) (eq? (car spec) 'lib))))
(append (sort (filter librec? allrecs) rec<?)
(sort (filter (lambda (x) (not (librec? x))) allrecs) rec<?)))
;; colldocs : -> (values (list-of (list string path)) (list-of string))
;; Returns two lists having equal length. Each item in the first list
;; contains a list containing a string (the directory) and a path (to
;; the doc.txt file). The second list contains the corresponding descriptive
;; names.
(define (colldocs)
(let loop ([dirrecs (find-doc-directory-records)]
[docs null]
[names null])
(cond
[(null? dirrecs) (values (reverse docs) (reverse names))]
[else
(let* ([dirrec (car dirrecs)]
[dir (directory-record-path dirrec)]
[info-proc (get-info/full dir)])
(if info-proc
(let ([doc.txt-path (info-proc 'doc.txt (lambda () #f))]
[name (info-proc 'name (lambda () #f))])
(if (and (path-string? doc.txt-path)
(string? name))
(loop (cdr dirrecs)
(cons (list dir (string->path doc.txt-path))
docs)
(cons (pleasant-name name dirrec)
names))
(loop (cdr dirrecs) docs names)))
(loop (cdr dirrecs) docs names)))])))
;; pleasant-name : string directory-record -> string
;; Generates a descriptive name for the collection/package.
(define (pleasant-name name dirrec)
(let ([spec (directory-record-spec dirrec)])
(if (and (pair? spec) (list? spec))
(case (car spec)
((lib) (format "~a collection" name))
((planet) (format "~a package ~s"
name
`(,@(cdr spec)
,(directory-record-maj dirrec)
,(directory-record-min dirrec)))))
name)))
(provide/contract
[colldocs (-> (values (listof (list/c path? path?))
(listof string?)))]))

65
collects/help/private/docpos.ss Normal file
View File

@ -0,0 +1,65 @@
(module docpos mzscheme
(require (lib "list.ss")
(lib "contract.ss"))
;; Define an order on the standard docs.
(define (standard-html-doc-position d)
(let ([str (path->string d)])
(if (equal? str "help")
-1
(let ([line (assoc str docs-and-positions)])
(if line
(caddr line)
100)))))
;; (listof (list string string number))
;; the first string is the collection name
;; the second string is the title of the the manual
;; the number determines the sorting order for the manuals in the manuals page
(define docs-and-positions
`(("r5rs" "Revised^5 Report on the Algorithmic Language Scheme" -50)
("mzscheme" "PLT MzScheme: Language Manual" -49)
("mred" "PLT MrEd: Graphical Toolbox Manual" -48)
("tour" "A Brief Tour of DrScheme" 0)
("drscheme" "PLT DrScheme: Programming Environment Manual" 1)
("srfi" "SRFI documents inside PLT" 3)
("mzlib" "PLT MzLib: Libraries Manual" 5)
("misclib" "PLT Miscellaneous Libraries: Reference Manual" 6)
("mrlib" "PLT MrLib: Graphical Libraries Manual" 7)
("framework" "PLT Framework: GUI Application Framework" 8)
("mzc" "PLT mzc: MzScheme Compiler Manual" 10)
("foreign" "PLT Foreign Interface Manual" 10)
("tools" "PLT Tools: DrScheme Extension Manual" 30)
("insidemz" "Inside PLT MzScheme" 50)
("web-server" "Web Server Manual" 60)
("swindle" "Swindle Manual" 61)
("plot" "PLoT Manual" 62)
("t-y-scheme" "Teach Yourself Scheme in Fixnum Days" 100)
("tex2page" "TeX2page" 101)
("beginning" "Beginning Student Language" 200)
("beginning-abbr" "Beginning Student with List Abbreviations Language" 201)
("intermediate" "Intermediate Student Language" 202)
("intermediate-lambda" "Intermediate Student with Lambda Language" 203)
("advanced" "Advanced Student Language" 204)
("teachpack" "Teachpacks for How to Design Programs" 205)
("teachpack-htdc" "Teachpacks for How to Design Classes" 206)
("profj-beginner" "ProfessorJ Beginner Language" 210)
("profj-intermediate" "ProfessorJ Intermediate Language" 211)
("profj-intermediate-access" "ProfessorJ Intermediate + access Language" 212)
("profj-advanced" "ProfessorJ Advanced Language" 213)))
(define known-docs (map (lambda (x) (cons (string->path (car x)) (cadr x))) docs-and-positions))
(provide/contract
[standard-html-doc-position (path? . -> . number?)]
[known-docs (listof (cons/c path? string?))]))

79
collects/help/private/finddoc.ss Normal file
View File

@ -0,0 +1,79 @@
(module finddoc mzscheme
(require (lib "dirs.ss" "setup")
(lib "match.ss")
"path.ss"
"get-help-url.ss")
(provide finddoc
finddoc-page
finddoc-page-anchor
find-doc-directory)
;; Creates a "file:" link into the indicated manual.
;; The link doesn't go to a particular anchor,
;; because "file:" does not support that.
(define (finddoc manual index-key label)
(match (lookup manual index-key label)
[(docdir index-key filename anchor title)
`(a ((href ,(string-append
"file:" (build-path docdir filename))))
,label)]
[m m]))
; finddoc-page-help : string string boolean -> string
; return url to the page where index-key is in manual,
; optionally append an anchor
(define (finddoc-page-help manual index-key anchor?)
(match (lookup manual index-key "dummy")
[(docdir index-key filename anchor title)
(cond
[(servlet-path? (string->path filename))
(string-append
filename (if anchor? (string-append "#" anchor) ""))]
[else
(get-help-url (build-path docdir filename) anchor)])]
[_ (error (format "Error finding index \"~a\" in manual \"~a\""
index-key manual))]))
; finddoc-page : string string -> string
; returns path for use by PLT Web server
; path is of form /doc/manual/page, or
; /servlet/<rest-of-path>
(define (finddoc-page manual index-key)
(finddoc-page-help manual index-key #f))
; finddoc-page-anchor : string string -> string
; returns path (with anchor) for use by PLT Web server
; path is of form /doc/manual/page#anchor, or
; /servlet/<rest-of-path>#anchor
(define (finddoc-page-anchor manual index-key)
(finddoc-page-help manual index-key #t))
(define ht (make-hash-table))
;; returns (list docdir index-key filename anchor title)
;; or throws an error
(define (lookup manual index-key label)
(let* ([key (string->symbol manual)]
[docdir (find-doc-directory manual)]
[l (hash-table-get ht key
(lambda ()
(let ([f (and docdir (build-path docdir "hdindex"))])
(if (and f (file-exists? f))
(let ([l (with-input-from-file f read)])
(hash-table-put! ht key l)
l)
(error 'finddoc "manual index ~s not installed" manual)))))]
[m (assoc index-key l)])
(if m
(cons docdir m)
(error 'finddoc "index key ~s not found in manual ~s" index-key manual))))
;; finds the full path of the doc directory, if one exists
;; input is just the short name of the directory (as a path)
(define (find-doc-directory doc)
(ormap (lambda (d)
(let ([p (build-path d doc)])
(and (directory-exists? p)
p)))
(get-doc-search-dirs))))

68
collects/help/private/get-help-url.ss Normal file
View File

@ -0,0 +1,68 @@
(module get-help-url mzscheme
#| Library responsible for turning a path on disk into a URL the help desk can use |#
(require (lib "file.ss")
"internal-hp.ss"
(lib "contract.ss")
(lib "etc.ss")
(lib "config.ss" "planet")
(lib "dirs.ss" "setup"))
; given a manual path, convert to absolute Web path
; manual path is an anchored path to a doc manual, never a servlet
(define get-help-url
(opt-lambda (manual-path [anchor #f])
(let ([segments (explode-path (normalize-path manual-path))])
(let loop ([candidates manual-path-candidates])
(cond
;; shouldn't happen, unless documentation is outside
;; the set of doc dirs:
[(null? candidates) "/cannot-find-docs.html"]
[else
(let ([candidate (car candidates)])
(cond
[(subpath/tail (car candidate) segments)
=>
(λ (l-o-path)
((cadr candidate) l-o-path anchor))]
[else
(loop (cdr candidates))]))])))))
(define manual-path-candidates '())
(define (maybe-add-candidate candidate host)
(with-handlers ([exn:fail? void])
(set! manual-path-candidates
(cons (list (explode-path (normalize-path candidate))
(λ (segments anchor)
(format "http://~a:~a/servlets/static.ss/~a~a~a"
internal-host
(internal-port)
host
(apply string-append (map (λ (x) (format "/~a" (path->string x)))
segments))
(if anchor
(string-append "#" anchor)
""))))
manual-path-candidates))))
;; Add doc dirs later, so that they take precedence:
(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))
(define (subpath/tail short long)
(let loop ([short short]
[long long])
(cond
[(null? short) long]
[(null? long) #f]
[(equal? (car short) (car long))
(loop (cdr short) (cdr long))]
[else #f])))
(provide/contract (get-help-url
(opt->
((or/c path? path-string?))
(string?)
string?))))

54
collects/help/private/internal-hp.ss Normal file
View File

@ -0,0 +1,54 @@
(module internal-hp mzscheme
(require (lib "dirs.ss" "setup")
(lib "config.ss" "planet")
"options.ss")
(provide internal-port
is-internal-host? internal-host
collects-hosts collects-dirs
doc-hosts doc-dirs
planet-host)
;; Hostnames defined here should not exist as real machines
;; The general idea is that there's one "virtual" host for
;; every filesystem tree that we need to access.
;; (now we use static.ss/host/yadayda instead of the virtual
;; host docX.localhost, but we still need to keep track of
;; the file system roots)
;; The "get-help-url.ss" library provides a function to
;; convert a path into a suitable URL (i.e., a URL using
;; the right virtual host).
;; The "gui.ss" library performs a bit of extra URL
;; processing at the last minute, sometimes switching
;; a URL for a manual to a different host. (That's needed
;; when cross-manual references are implemented as relative
;; URLs.)
(define internal-host "localhost")
(define (is-internal-host? str)
(member str all-internal-hosts))
(define (generate-hosts prefix dirs)
(let loop ([dirs dirs][n 0])
(if (null? dirs)
null
(cons (format "~a~a" prefix n)
(loop (cdr dirs) (add1 n))))))
(define planet-host "planet")
(define collects-dirs
(get-collects-search-dirs))
(define collects-hosts
(generate-hosts "collects" collects-dirs))
(define doc-dirs
(get-doc-search-dirs))
(define doc-hosts
(generate-hosts "doc" doc-dirs))
(define all-internal-hosts
(append (list internal-host planet-host)
collects-hosts
doc-hosts)))

380
collects/help/private/manuals.ss Normal file
View File

@ -0,0 +1,380 @@
(module manuals mzscheme
(require (lib "list.ss")
(lib "date.ss")
(lib "string-constant.ss" "string-constants")
(lib "xml.ss" "xml")
(lib "contract.ss")
(lib "getinfo.ss" "setup")
(lib "uri-codec.ss" "net")
(lib "dirs.ss" "setup")
(lib "match.ss")
"finddoc.ss"
"colldocs.ss"
"docpos.ss"
"standard-urls.ss"
"get-help-url.ss"
"../servlets/private/util.ss")
;; type sec = (make-sec name regexp (listof regexp))
(define-struct sec (name reg seps))
;; sections : (listof sec)
;; determines the section breakdown for the manuals
;; elements in the outer list:
;; string : name of section
;; predicate : determines if a manual is in the section (based on its title)
;; breaks -- where to insert newlines
(define sections
(list (make-sec "Getting started"
#rx"(Tour)|(Teach Yourself)"
'())
(make-sec "Languages"
#rx"Language|MrEd"
'(#rx"Beginning Student" #rx"ProfessorJ Beginner"))
(make-sec "Tools" #rx"PLT DrScheme|PLT mzc|TeX2page|Web Server|PLoT" '())
(make-sec "Libraries" #rx"SRFI|MzLib|Framework|PLT Miscellaneous|Teachpack|Swindle" '())
(make-sec "Writing extensions" #rx"Tools|Inside|Foreign" '())
(make-sec "Other" #rx"" '())))
; main-manual-page : string -> xexpr
; return link to main manual page of a doc collection, like "mred"
(define (main-manual-page manual)
(let* ([entry (assoc (string->path manual) known-docs)]
[name (or (and entry (cdr entry))
manual)]
[doc-dir (find-doc-directory manual)])
(if doc-dir
(let ([href (get-help-url doc-dir)])
`(A ((HREF ,href)) ,name))
name)))
; manual-entry: string string string -> xexpr
; man is manual name
; ndx is index into the manual
; txt is the link text
(define (manual-entry man ndx txt)
(with-handlers ([exn:fail?
;; warning: if the index file isn't present, this page
(lambda (x)
`(font ((color "red")) ,txt " [" ,(exn-message x) "]"))])
`(A ((HREF ,(finddoc-page man ndx))) ,txt)))
(define (basename path)
(let-values ([(dir name dir?) (split-path path)]) name))
(define (find-doc-names)
(let* ([dirs (find-doc-directories)]
[installed (map basename dirs)]
[uninstalled (filter (lambda (x) (not (member (car x) installed)))
known-docs)])
(append (map (lambda (short-name long-name)
(cons short-name (get-doc-name long-name)))
installed dirs)
uninstalled)))
;; find-doc-directories : -> (listof path)
;; constructs a sorted list of directories where documentation may reside.
(define (find-doc-directories)
(let ([unsorted (append (find-info.ss-doc-directories)
(find-doc-directories-in-toplevel-docs))])
(sort unsorted compare-docs)))
(define (find-info.ss-doc-directories)
(let ([dirs (find-relevant-directories '(html-docs) 'all-available)])
(let loop ([dirs dirs])
(cond
[(null? dirs) null]
[else (let* ([dir (car dirs)]
[info (get-info/full dir)])
(cond
[info
(let ([html-doc-paths (info 'html-docs (lambda () #f))])
(cond
[(and (list? html-doc-paths)
(andmap path-string? html-doc-paths))
(let ([candidates (map (lambda (x) (build-path dir x)) html-doc-paths)])
(for-each (λ (c)
(unless (directory-exists? c)
(fprintf (current-error-port)
"found reference to ~a in html-docs for ~a, but it is not a directory\n"
(path->string c)
(path->string dir))))
candidates)
(append (filter directory-exists? candidates)
(loop (cdr dirs))))]
[else
(loop (cdr dirs))]))]
[else (loop (cdr dirs))]))]))))
(define (find-doc-directories-in-toplevel-docs)
(apply append
(map (lambda (docs-path)
(filter directory-exists?
(map (lambda (doc-path)
(build-path docs-path doc-path))
(if (directory-exists? docs-path)
(filter (lambda (x)
(not (member (path->string x)
'(".svn" "CVS"))))
(directory-list docs-path))
'()))))
(get-doc-search-dirs))))
(define (find-manuals)
(let* ([docs (sort (filter get-index-file (find-doc-directories))
compare-docs)]
[names (map get-doc-name docs)]
[names+paths (map cons names docs)])
(let-values ([(collections-doc-files collection-names) (colldocs)])
`((H1 "Installed Manuals")
,@(if (repos-or-nightly-build?)
(list
'(b "Subversion: ")
`(a ((mzscheme
,(to-string/escape-quotes
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)))))
,(string-constant plt:hd:refresh-all-manuals))
'nbsp 'nbsp
`(a ((href ,flush-manuals-url)) "flush index and keyword cache")
'(br))
(list))
,@(build-known-manuals names+paths)
(h3 "Doc.txt")
(ul ,@(map
(lambda (collection-doc-file name)
(let ([path (build-path (car collection-doc-file) (cadr collection-doc-file))])
`(li ,(cond
[(file-exists? path)
`(a ((href ,(format "/servlets/doc-anchor.ss?file=~a&name=~a&caption=~a"
;; escape colons and other junk
(uri-encode (path->string path))
(uri-encode name)
(format "Documentation for ~a " name))))
,(format "~a " name))]
[else
`(font ((color "red"))
,(format "~a: specified doc.txt file (~a) not found"
name path))]))))
collections-doc-files
collection-names))
,@(let ([uninstalled (get-uninstalled docs)])
(if (null? uninstalled)
'()
`((h3 "Uninstalled Manuals")
(ul ,@(map
(lambda (doc-pair)
(let* ([manual (car doc-pair)]
[name (cdr doc-pair)]
[manual-path (find-doc-directory manual)])
`(li "Download and install "
(a ((mzscheme
,(to-string/escape-quotes
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
(list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path)
,(path->bytes manual))
,name))))))
,name)
,(if (and manual-path
(or (file-exists? (build-path manual-path "hdindex"))
(file-exists? (build-path manual-path "keywords"))))
" (index installed)"
""))))
uninstalled)))))))))
;; build-known-manuals : (listof (cons string[title] string[path])) -> (listof xexpr)
(define (build-known-manuals names+paths)
(let loop ([sections sections]
[manuals names+paths])
(cond
[(null? sections) null]
[else
(let* ([section (car sections)]
[in (filter (lambda (x) (regexp-match (sec-reg section)
(car x)))
manuals)]
[out (filter (lambda (x) (not (regexp-match (sec-reg section)
(car x))))
manuals)])
(append (build-known-section section in)
(loop (cdr sections) out)))])))
;; build-known-section : sec (listof (cons string[title] string[path]))) -> (listof xexpr)
(define (build-known-section sec names+paths)
(if (null? names+paths)
'()
`((h3 ,(sec-name sec))
(ul ,@(map (match-lambda
["<p>" '(p)]
[(title . path) (mk-link path title)])
(let loop ([breaks (sec-seps sec)]
[names+paths names+paths])
(cond
[(null? breaks) names+paths]
[else
(let ([break (car breaks)])
(loop (cdr breaks)
(break-between (car breaks) names+paths)))])))))))
;; break-between : regexp
;; (listof (union string (cons string string)))
;; -> (listof (union string (cons string string)))
;; adds the para-mark string into the list at the first place
;; that the regexp fails to match (not counting other para-marks
;; in the list)
(define (break-between re l)
(let ([para-mark "<p>"])
(let loop ([l l])
(cond
[(null? l) null]
[else
(let ([fst (car l)])
(cond
[(pair? fst)
(let ([name (car fst)])
(if (regexp-match re name)
(cons para-mark l)
(cons fst (loop (cdr l)))))]
[else (cons fst (loop (cdr l)))]))]))))
;; mk-link : string string -> xexpr
(define (mk-link doc-path name)
(let* ([manual-name (basename doc-path)]
[index-file (get-index-file doc-path)])
`(li (a ((href ,(get-help-url (build-path doc-path index-file))))
,name)
,@(cond
[(and (repos-or-nightly-build?)
(file-exists? (build-path doc-path index-file)))
`((br)
'nbsp
'nbsp
(font ((size "-1"))
,@(if (is-known-doc? doc-path)
(list
"["
`(a ((mzscheme
,(to-string/escape-quotes
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
(list (cons ((dynamic-require '(lib "refresh-manuals.ss" "help") 'bytes-to-path)
,(path->bytes manual-name))
,name))))))
,(string-constant plt:hd:refresh))
"]" 'nbsp)
(list))))]
[else
(list
(format (string-constant plt:hd:manual-installed-date)
(date->string
(seconds->date
(file-or-directory-modify-seconds
(build-path doc-path index-file))))))]))))
(define (to-string/escape-quotes exp)
(regexp-replace* #rx"\"" (format "~s" exp) "|"))
;; get-doc-name : path -> string
(define cached-doc-names (make-hash-table 'equal))
(define (get-doc-name doc-dir)
(hash-table-get cached-doc-names doc-dir
(lambda ()
(let ([res (compute-doc-name doc-dir)])
(hash-table-put! cached-doc-names doc-dir res)
res))))
;; compute-doc-name : path -> string[title of manual]
;; gets the title either from the known docs list, by parsing the
;; html, or if both those fail, by using the name of the directory
;; Special-cases the help collection. It's not a known doc directory
;; per se, so it won't appear in known-docs, but its name is always
;; the same.
(define (compute-doc-name doc-dir)
(let ([doc-short-dir-name (basename doc-dir)])
(cond
[(equal? (string->path "help") doc-short-dir-name) "PLT Help Desk"]
[(get-known-doc-name doc-dir) => values]
[else (let* ([main-file (get-index-file doc-dir)]
[m (and main-file
(call-with-input-file (build-path doc-dir main-file)
(lambda (inp) (regexp-match re:title inp))))])
(if m
(bytes->string/utf-8 (cadr m))
(path->string doc-short-dir-name)))])))
(define re:title
#rx"<[tT][iI][tT][lL][eE]>[ \t\r\n]*(.*?)[ \t\r\n]*</[tT][iI][tT][lL][eE]>")
;; is-known-doc? : string[path] -> boolean
(define (is-known-doc? doc-path)
(and (assoc (basename doc-path) known-docs) #t))
;; get-known-doc-name : string[full-path] -> (union string #f)
(define (get-known-doc-name doc-path)
(cond [(assoc (basename doc-path) known-docs) => cdr] [else #f]))
;; get-uninstalled : (listof path) -> (listof (cons path string[docs-name]))
(define (get-uninstalled docs)
(let ([ht (make-hash-table 'equal)])
(for-each (lambda (known-doc)
(hash-table-put! ht
(car known-doc)
(cdr known-doc)))
known-docs)
(for-each (lambda (doc) (hash-table-remove! ht (basename doc))) docs)
(sort (hash-table-map ht cons)
(λ (a b) (compare-docs (car a) (car b))))))
(define (compare-docs a b)
(let ([ap (standard-html-doc-position (basename a))]
[bp (standard-html-doc-position (basename b))])
(cond [(= ap bp) (string<? (path->string a) (path->string b))]
[else (< ap bp)])))
;; get-manual-index : string -> html
(define (get-manual-index manual-dirname) (get-help-url (build-path (find-doc-dir) manual-dirname)))
;; get-index-file : path -> (union #f path)
;; returns the name of the main file, if one can be found
(define (get-index-file doc-dir)
(cond
[(file-exists? (build-path doc-dir "index.htm"))
(build-path "index.htm")]
[(file-exists? (build-path doc-dir "index.html"))
(build-path "index.html")]
[(tex2page-detected doc-dir)
=>
(lambda (x) x)]
[else #f]))
;; tex2page-detected : string -> (union #f string)
(define (tex2page-detected dir)
(let loop ([contents (directory-list dir)])
(cond
[(null? contents) #f]
[else (let* ([file (car contents)]
[m (regexp-match #rx#"(.*)-Z-H-1.html" (path->bytes file))])
(or (and m
(file-exists? (build-path dir file))
(let ([index-file
(bytes->path
(bytes-append (cadr m) #".html"))])
(if (file-exists? (build-path dir index-file))
index-file
#f)))
(loop (cdr contents))))])))
(provide find-manuals
main-manual-page
finddoc
finddoc-page-anchor)
(provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
[finddoc-page (string? string? . -> . string?)]
[get-doc-name (path? . -> . string?)]
[find-doc-directories (-> (listof path?))]
[find-doc-directory (path? . -> . (or/c false/c path?))]
[find-doc-names (-> (listof (cons/c path? string?)))]
[get-manual-index (-> string? string?)]
[get-index-file (path? . -> . (or/c false/c path?))]))

22
collects/help/private/options.ss Normal file
View File

@ -0,0 +1,22 @@
(module options mzscheme
;; This module provides configuration options that are shared
;; between servlets and the web-server. (Mostly to allow
;; configuration as an application or as a standalone server.)
(provide helpdesk-platform internal-port)
;; internal browser or external browser?
;; (used to produce simpler html for the internal browser)
(define helpdesk-platform
(make-parameter
'internal-browser-simple ; main page only
;; 'internal-browser ; menu + main page
;; 'external-browser
))
;; Port for the server to listen on
;; (relevant only for a standalone server)
(define internal-port (make-parameter 8012))
)

10
collects/help/private/path.ss Normal file
View File

@ -0,0 +1,10 @@
(module path mzscheme
(require (lib "contract.ss"))
(define (servlet-path? path)
(if (regexp-match #rx#"^/servlets/"
(path->bytes path))
#t
#f))
(provide/contract
[servlet-path? (path? . -> . boolean?)]))

134
collects/help/private/standard-urls.ss Normal file
View File

@ -0,0 +1,134 @@
(module standard-urls mzscheme
(require (lib "uri-codec.ss" "net")
(lib "dirs.ss" "setup")
(lib "contract.ss")
(lib "config.ss" "planet")
(lib "help-desk-urls.ss" "help")
"../servlets/private/util.ss"
"internal-hp.ss"
"get-help-url.ss")
(provide home-page-url host+dirs)
(define (search-type? x)
(member x '("keyword" "keyword-index" "keyword-index-text")))
(define (search-how? x)
(member x '("exact-match" "containing-match" "regexp-match")))
(define (base-docs-url)
(if (repos-or-nightly-build?)
"http://pre.plt-scheme.org/docs"
(string-append "http://download.plt-scheme.org/doc/" (version))))
(define (make-docs-plt-url manual-name)
(format "~a/bundles/~a-doc.plt" (base-docs-url) manual-name))
(define (make-docs-html-url manual-name)
(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))
(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 relative-results-url-prefix "/servlets/results.ss?")
(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)
coll
(uri-encode name)
(uri-encode link)))
(define (make-relative-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
(string-append
relative-results-url-prefix
(make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
(define (make-results-url search-string search-type match-type lucky? manuals doc.txt? lang-name)
(string-append
results-url-prefix
(make-results-url-args search-string search-type match-type lucky? manuals doc.txt? lang-name)))
(define (make-results-url-args search-string search-type match-type lucky? manuals doc.txt? language-name)
(let ([start
(format
(string-append "search-string=~a&"
"search-type=~a&"
"match-type=~a&"
"lucky=~a&"
"manuals=~a&"
"doctxt=~a")
(uri-encode search-string)
search-type
match-type
(if lucky? "true" "false")
(uri-encode (format "~s" (map path->bytes manuals)))
(if doc.txt? "true" "false"))])
(if language-name
(string-append start (format "&langname=~a" (uri-encode language-name)))
start)))
; sym, string assoc list
(define hd-locations
`((hd-tour ,(format "~a/index.html" (get-help-url (build-path (find-doc-dir) "tour"))))
(release-notes ,url-helpdesk-release-notes)
(plt-license ,url-helpdesk-license)
(front-page ,url-helpdesk-home)))
(define hd-location-syms (map car hd-locations))
(define (get-hd-location sym)
; the assq is guarded by the contract
(cadr (assq sym hd-locations)))
; host+dirs : (list (cons host-string dir-path))
; association between internal (in normal Helpdesk also virtual)
; hosts and their corresponding file root.
(define host+dirs
(map cons
(append collects-hosts doc-hosts)
(append collects-dirs doc-dirs)))
(define (host+file->path host file-path)
(cond [(assoc host host+dirs)
=> (lambda (internal-host+path)
(let ([path (cdr internal-host+path)])
(build-path path file-path)))]
[(equal? host "planet")
(build-path (PLANET-DIR) file-path)]
[else #f]))
(provide host+file->path)
(provide search-type? search-how?)
(provide/contract
(make-relative-results-url (string?
search-type?
search-how?
any/c
(listof path?)
any/c
(or/c false/c string?) . -> . string?))
(make-results-url (string?
search-type? search-how? any/c
(listof path?)
any/c
(or/c false/c string?)
. -> .
string?))
(flush-manuals-url string?)
(flush-manuals-path string?)
(make-missing-manual-url (string? string? string? . -> . string?))
(get-hd-location ((lambda (sym) (memq sym hd-location-syms))
. -> .
string?))
[prefix-with-server (string? . -> . string?)]
[make-docs-plt-url (string? . -> . string?)]
[make-docs-html-url (string? . -> . string?)]))

83
collects/help/servlets/private/url.ss Normal file
View File

@ -0,0 +1,83 @@
(module url mzscheme
(require "../../private/internal-hp.ss")
(provide (all-defined))
(define url-helpdesk-root
(format "http://~a:~a/servlets/" internal-host (internal-port)))
(define url-helpdesk-home (string-append url-helpdesk-root "home.ss"))
(define url-helpdesk-results (string-append url-helpdesk-root "results.ss"))
(define url-helpdesk-master-index (string-append url-helpdesk-root "master-index.ss"))
(define (url-home-subpage subpage-str)
(string-append url-helpdesk-home "?subpage=" subpage-str))
(define (version-major)
; TODO: Fix this
(cond [(regexp-match #px"^(\\d+).*$" (version))
=> cadr]
[else "352"]))
(define (url-manual-on-doc-server manual)
(format "http://download.plt-scheme.org/doc/~a/html/~a/"
(version-major) manual))
(define (url-static doc manual path)
(format "~astatic.ss/~a/~a/~a"
url-helpdesk-root doc manual path))
(define url-external-announcement-list-archive "http://list.cs.brown.edu/pipermail/plt-announce/")
(define url-external-discussion-list-archive "http://list.cs.brown.edu/pipermail/plt-scheme/")
(define url-external-discussion-list-archive-old "http://www.cs.utah.edu/plt/mailarch/")
(define url-external-mailing-list-subscription "http://www.plt-scheme.org/maillist/")
(define url-external-mrflow "http://www.plt-scheme.org/software/mrflow/")
(define url-external-mrspidey "http://www.plt-scheme.org/software/mrspidey/")
(define url-external-mysterx "http://www.plt-scheme.org/software/mysterx/")
(define url-external-mzcom "http://www.plt-scheme.org/software/mzcom/")
(define url-external-send-bug-report "http://bugs.plt-scheme.org/")
(define url-external-tour-of-drscheme "http://www.plt-scheme.org/software/drscheme/tour/")
(define url-external-planet "http://planet.plt-scheme.org/")
(define url-external-srpersist "http://www.plt-scheme.org/software/srpersist/")
(define url-helpdesk-acknowledge (url-home-subpage "acknowledge"))
(define url-helpdesk-batch (url-home-subpage "batch"))
(define url-helpdesk-books (url-home-subpage "books"))
(define url-helpdesk-cgi (url-home-subpage "cgi"))
(define url-helpdesk-databases (url-home-subpage "databases"))
(define url-helpdesk-documentation (url-home-subpage "documentation"))
(define url-helpdesk-drscheme (url-home-subpage "drscheme"))
(define url-helpdesk-drscheme-faq (url-static "doc1" "drscheme" "drscheme-Z-H-5.html#node_chap_5"))
(define url-helpdesk-drscheme-manual (url-static "doc1" "drscheme" "index.htm"))
(define url-helpdesk-faq (url-home-subpage "faq"))
(define url-helpdesk-graphics (url-home-subpage "graphics"))
(define url-helpdesk-help (url-home-subpage "help"))
(define url-helpdesk-how-to-search (url-home-subpage "how-to-search"))
(define url-helpdesk-interface-essentials (url-static "doc1" "drscheme" "drscheme-Z-H-2.html#node_chap_2"))
(define url-helpdesk-known-bugs (url-home-subpage "known-bugs"))
(define url-helpdesk-languages (url-home-subpage "languages"))
(define url-helpdesk-libraries (url-home-subpage "libraries"))
(define url-helpdesk-license (url-home-subpage "license"))
(define url-helpdesk-manuals (url-home-subpage "manuals"))
(define url-helpdesk-mailing-lists (url-home-subpage "mailing-lists"))
(define url-helpdesk-mzlib (url-static "doc1" "mzlib" "mzlib.html"))
(define url-helpdesk-patches (url-home-subpage "patches"))
(define url-helpdesk-program-design (url-home-subpage "program-design"))
(define url-helpdesk-release (url-home-subpage "release"))
(define url-helpdesk-release-notes (url-home-subpage "release-notes"))
(define url-helpdesk-script (url-home-subpage "script"))
(define url-helpdesk-search (url-home-subpage "search"))
(define url-helpdesk-software (url-home-subpage "software"))
(define url-helpdesk-srpersist (url-home-subpage "srpersist"))
(define url-helpdesk-stand-alone (url-home-subpage "stand-alone"))
(define url-helpdesk-system (url-home-subpage "system"))
(define url-helpdesk-teachpacks (url-home-subpage "teachpacks"))
(define url-helpdesk-teachscheme (url-home-subpage "teachscheme"))
(define url-helpdesk-teachpacks-for-htdp (url-static "doc1" "teachpack" "index.html#HtDP"))
(define url-helpdesk-teachpacks-for-htdc (url-static "doc1" "teachpack-htdc" "index.html#HtDC"))
(define url-helpdesk-teach-yourself (url-static "doc1" "t-y-scheme" "index.htm"))
(define url-helpdesk-tour (url-home-subpage "tour"))
(define url-helpdesk-why-drscheme (url-home-subpage "why-drscheme"))
)

114
collects/help/servlets/private/util.ss Normal file
View File

@ -0,0 +1,114 @@
(module util mzscheme
(require (lib "file.ss")
(lib "list.ss")
(lib "xml.ss" "xml")
(lib "uri-codec.ss" "net")
(lib "string-constant.ss" "string-constants")
(lib "contract.ss"))
;; would be nice if this could use version:version from the framework.
(define (plt-version)
(let ([mz-version (version)]
[stamp-collection
(with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
(collection-path "repos-time-stamp"))])
(if (and stamp-collection
(file-exists? (build-path stamp-collection "stamp.ss")))
(format "~a-svn~a" mz-version
(dynamic-require '(lib "repos-time-stamp/stamp.ss") 'stamp))
mz-version)))
(define home-page
`(a ([href "/servlets/home.ss"] [target "_top"])
,(string-constant plt:hd:home)))
(define (get-pref/default pref default)
(get-preference pref (lambda () default)))
(define (get-bool-pref/default pref default)
(let ([raw-pref (get-pref/default pref default)])
(if (string=? raw-pref "false") #f #t)))
(define (put-prefs names vals)
(put-preferences names vals))
(define search-height-default "85")
(define search-bg-default "lightsteelblue")
(define search-text-default "black")
(define search-link-default "darkblue")
(define *the-highlight-color* "forestgreen")
;; string xexpr ... -> xexpr
(define (with-color color . s)
`(font ([color ,color]) ,@s))
;; xexpr ... -> xexpr
(define (color-highlight . s)
(apply with-color *the-highlight-color* s))
(define repos-or-nightly-build?
(let ([helpdir (collection-path "help")])
(lambda ()
(or (directory-exists? (build-path helpdir ".svn"))
(directory-exists? (build-path helpdir "CVS"))
(with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
(collection-path "repos-time-stamp"))))))
; string string -> xexpr
(define (collection-doc-link coll txt)
(let ([coll-file (build-path (collection-path coll) "doc.txt")])
(if (file-exists? coll-file)
`(a ((href
,(format
"~a?file=~a&name=~a&caption=Documentation for the ~a collection"
"/servlets/doc-anchor.ss"
(uri-encode (path->string coll-file))
coll
coll)))
,txt)
"")))
;; (listof string) -> string
;; result is forward-slashed web path
;; e.g. ("foo" "bar") -> "foo/bar"
(define (fold-into-web-path lst)
(foldr (lambda (s a) (if a (string-append s "/" a) s)) #f lst))
(define (format-collection-message s)
`(b ((style "color:green")) ,s))
(define (make-javascript . ss)
`(script ([language "Javascript"])
,(make-comment (apply string-append "\n"
(map (lambda (s) (string-append s "\n")) ss)))))
(define (redir-javascript k-url)
(make-javascript "function redir() {"
(string-append " document.location.href=\"" k-url "\"")
"}"))
(define (onload-redir secs)
(string-append "setTimeout(\"redir()\","
(number->string (* secs 1000)) ")"))
(provide/contract
[fold-into-web-path ((listof string?) . -> . string?)])
(provide get-pref/default
get-bool-pref/default
put-prefs
repos-or-nightly-build?
search-height-default
search-bg-default
search-text-default
search-link-default
color-highlight
with-color
collection-doc-link
home-page
format-collection-message
plt-version
make-javascript
redir-javascript
onload-redir))