removed most stuff, replaced with a command-line searcher
svn: r7773
This commit is contained in:
Robby Findler
parent
ac98c07210
commit
1c61b75f18
|
|
@ -1,542 +0,0 @@
|
|||
|
||||
(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
|
||||
" <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)))
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
(module help-desk-server mzscheme
|
||||
|
||||
;; PURPOSE
|
||||
;; This file launches a web-server serving an online
|
||||
;; version of the HelpDesk pages.
|
||||
;; This is intended for testing the online version,
|
||||
;; not as a way of deplying it.
|
||||
|
||||
;; NOTES
|
||||
;; The web-server uses the port given by internal-port
|
||||
;; in "private/options.ss" by default.
|
||||
|
||||
;; Startpage:
|
||||
;; http://localhost:8012/servlets/home.ss
|
||||
;; (where 8012 is the port given by internal-port)
|
||||
|
||||
|
||||
(require (lib "web-server.ss" "web-server")
|
||||
(lib "web-config-unit.ss" "web-server")
|
||||
"private/config.ss"
|
||||
"private/internal-hp.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))]))
|
||||
|
||||
;; start the HelpDesk server, and store a shutdown
|
||||
(define shutdown
|
||||
(serve/web-config@ (make-config)))
|
||||
|
||||
(printf "\nStart here: http://~a:~a/servlets/home.ss\n\n"
|
||||
internal-host (internal-port))
|
||||
|
||||
(printf "Press enter to shutdown.\n")
|
||||
(with-handlers ([exn:break? (lambda (exn) (shutdown) (exit))])
|
||||
(read-line))
|
||||
(shutdown)
|
||||
|
||||
)
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(module help-desk-urls mzscheme
|
||||
(require "servlets/private/url.ss")
|
||||
(provide (all-from "servlets/private/url.ss")))
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
(module help-desk mzscheme
|
||||
(require
|
||||
"bug-report.ss" ;; this is require'd here to get the prefs defaults setup done early.
|
||||
"private/options.ss" ;; same reason
|
||||
|
||||
"private/manuals.ss"
|
||||
"private/buginfo.ss"
|
||||
"private/standard-urls.ss"
|
||||
|
||||
"private/link.ss"
|
||||
(lib "contract.ss")
|
||||
(lib "class.ss"))
|
||||
|
||||
(helpdesk-platform 'internal-browser-simple)
|
||||
|
||||
(provide help-desk-frame<%>)
|
||||
|
||||
(provide/contract
|
||||
(add-help-desk-font-prefs (boolean? . -> . any))
|
||||
(set-bug-report-info! any/c)
|
||||
(find-doc-names (-> (listof (cons/c path? string?))))
|
||||
(goto-manual-link (string? string? . -> . any))
|
||||
|
||||
(goto-hd-location ((symbols 'hd-tour 'release-notes 'plt-license) . -> . any))
|
||||
(new-help-desk (-> (is-a?/c help-desk-frame<%>)))
|
||||
(show-help-desk (-> any))
|
||||
(add-help-desk-mixin (-> mixin-contract void?))
|
||||
(search-for-docs (string?
|
||||
search-type?
|
||||
search-how?
|
||||
any/c
|
||||
(listof path?) ;; manual names
|
||||
. -> .
|
||||
any))
|
||||
(find-help-desk-frame (-> (union false/c (is-a?/c help-desk-frame<%>))))
|
||||
(search-for-docs/in-frame ((is-a?/c help-desk-frame<%>)
|
||||
string?
|
||||
search-type?
|
||||
search-how?
|
||||
any/c
|
||||
(listof path?) ;; manual names
|
||||
. -> .
|
||||
any))))
|
||||
|
|
@ -1,41 +1,7 @@
|
|||
#|
|
||||
#lang scheme/base
|
||||
|
||||
This file contains all of the initialization of the Help Desk application.
|
||||
It is only loaded when Help Desk is run by itself (outside DrScheme).
|
||||
|
||||
|#
|
||||
|
||||
(module help mzscheme
|
||||
(require "bug-report.ss" ;; load now to init the preferences early enough
|
||||
(lib "cmdline.ss")
|
||||
(lib "class.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "external.ss" "browser")
|
||||
"private/link.ss"
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(command-line
|
||||
"help-desk"
|
||||
(current-command-line-arguments))
|
||||
|
||||
(add-help-desk-font-prefs #f)
|
||||
(color-prefs:add-background-preferences-panel)
|
||||
(preferences:add-warnings-checkbox-panel)
|
||||
(install-help-browser-preference-panel)
|
||||
|
||||
;; for use by the bug report frame.
|
||||
;(namespace-set-variable-value! 'help-desk:frame-mixin (make-bug-report/help-desk-mixin 'the-hd-cookie))
|
||||
|
||||
(handler:current-create-new-window
|
||||
(lambda (filename)
|
||||
(let ([browser-frame '((hd-cookie-new-browser the-hd-cookie))])
|
||||
(when (and filename
|
||||
(file-exists? filename))
|
||||
(send (send (send browser-frame get-hyper-panel) get-canvas) goto-url
|
||||
(string-append "file://" filename)
|
||||
#f))
|
||||
browser-frame)))
|
||||
|
||||
(new-help-desk))
|
||||
|
||||
(require "private/search.ss")
|
||||
(define argv (current-command-line-arguments))
|
||||
(when (equal? argv #())
|
||||
(error 'help-desk "expected a search term on the command line"))
|
||||
(generate-search-results (vector->list argv))
|
||||
|
|
|
|||
|
|
@ -1,19 +1,16 @@
|
|||
; help collection
|
||||
(module info setup/infotab
|
||||
(define name "Help")
|
||||
(define doc.txt "doc.txt")
|
||||
;(define doc.txt "doc.txt")
|
||||
(define compile-subcollections
|
||||
'(("help" "private")
|
||||
#|
|
||||
("help" "servlets")
|
||||
("help" "servlets" "private")
|
||||
("help" "servlets" "release")
|
||||
("help" "servlets" "scheme")
|
||||
("help" "servlets" "scheme" "misc")))
|
||||
(define help-desk-message
|
||||
"Mr: (require (lib \"help-desk.ss\" \"help\"))")
|
||||
("help" "servlets" "scheme" "misc")
|
||||
|#
|
||||
))
|
||||
(define mred-launcher-libraries '("help.ss"))
|
||||
(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")))
|
||||
(define mred-launcher-names '("Help Desk")))
|
||||
|
|
|
|||
|
|
@ -1,110 +0,0 @@
|
|||
(module installer mzscheme
|
||||
(provide installer)
|
||||
|
||||
(require (lib "match.ss")
|
||||
(lib "file.ss")
|
||||
(lib "list.ss")
|
||||
(lib "dirs.ss" "setup")
|
||||
"servlets/home.ss")
|
||||
|
||||
(define (installer path)
|
||||
(create-index-file))
|
||||
|
||||
(define index-file "hdindex")
|
||||
|
||||
;; assume that "help" is in the main doc directory
|
||||
(define dest-dir (build-path (find-doc-dir) "help"))
|
||||
|
||||
(define (create-index-file)
|
||||
(gen-index servlet-dir)
|
||||
(set! index (append index (generate-index-for-static-pages)))
|
||||
(with-output-to-file (build-path dest-dir index-file)
|
||||
(lambda ()
|
||||
(printf "(\n")
|
||||
(for-each (lambda (x) (printf "~s\n" x)) index)
|
||||
(printf ")\n"))
|
||||
'truncate))
|
||||
|
||||
(define servlet-dir (normalize-path
|
||||
(build-path (collection-path "help") "servlets")))
|
||||
(define exploded-servlet-dir-len (length (explode-path servlet-dir)))
|
||||
|
||||
(unless (directory-exists? dest-dir)
|
||||
(make-directory* dest-dir))
|
||||
(current-directory dest-dir)
|
||||
|
||||
(define (get-servlet-files dir)
|
||||
(let* ([all-files
|
||||
(map (lambda (f) (build-path dir f))
|
||||
(directory-list dir))]
|
||||
[servlet-files
|
||||
(filter (lambda (s)
|
||||
(regexp-match #rx#"[.]ss$" (path->bytes s)))
|
||||
all-files)]
|
||||
[dirs
|
||||
(filter directory-exists? all-files)])
|
||||
(apply append servlet-files
|
||||
(map get-servlet-files dirs))))
|
||||
|
||||
; path is absolute, and has the servlet dir as a prefix
|
||||
(define (relativize-and-slashify path)
|
||||
(let* ([exp-path (explode-path path)]
|
||||
[prefix-len (sub1 exploded-servlet-dir-len)]
|
||||
[relative-exp-path
|
||||
(let loop ([p exp-path] [n 0])
|
||||
; leave off prefix up to servlet dir
|
||||
(if (>= n prefix-len)
|
||||
p
|
||||
(loop (cdr p) (add1 n))))])
|
||||
(fold-into-web-path relative-exp-path)))
|
||||
|
||||
; (listof string) -> string
|
||||
; result is forward-slashed web path
|
||||
; e.g. ("foo" "bar") -> "foo/bar"
|
||||
(define (fold-into-web-path lst)
|
||||
(apply string-append
|
||||
(cdr (apply append (map (lambda (x) (list "/" (path->string x)))
|
||||
lst)))))
|
||||
|
||||
(define index '())
|
||||
|
||||
(define (add-index-entry! val file name title)
|
||||
(set! index
|
||||
(cons (list val
|
||||
(string-append "/" (relativize-and-slashify file))
|
||||
name
|
||||
title)
|
||||
index)))
|
||||
|
||||
(define (gen-index dir)
|
||||
(let* ([all-files (directory-list)]
|
||||
[servlet-files (get-servlet-files dir)])
|
||||
(for-each
|
||||
(lambda (file)
|
||||
(let ([port (open-input-file file)]
|
||||
[title-value #f])
|
||||
(let loop ()
|
||||
(let ([sexp (with-handlers ([exn:fail:read?
|
||||
(lambda (x)
|
||||
(fprintf (current-error-port)
|
||||
"couldn't read ~a: ~a\n"
|
||||
file
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
(format "~s" x)))
|
||||
#f)])
|
||||
(read port))])
|
||||
(unless (eof-object? sexp)
|
||||
(let loop ([exp sexp])
|
||||
(match exp
|
||||
[`(title ,(? string? title))
|
||||
(set! title-value title)]
|
||||
[`(a ((name ,(? string? name)) (value ,(? string? value))))
|
||||
(add-index-entry! value file name
|
||||
(or title-value (path->string file)))]
|
||||
[_ (when (pair? exp)
|
||||
(begin (loop (car exp))
|
||||
(loop (cdr exp))))]))
|
||||
(loop))))))
|
||||
servlet-files))))
|
||||
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
(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))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
(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?)))]))
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
(module config mzscheme
|
||||
(require (lib "file.ss")
|
||||
(lib "web-config-unit.ss" "web-server")
|
||||
(lib "dirs.ss" "setup")
|
||||
(lib "config.ss" "planet")
|
||||
"internal-hp.ss"
|
||||
(lib "namespace.ss" "web-server" "configuration"))
|
||||
|
||||
(provide make-config)
|
||||
|
||||
(define (make-config)
|
||||
(let* ([build-normal-path
|
||||
(lambda args
|
||||
(normalize-path
|
||||
(apply build-path args)))]
|
||||
[help-path (build-normal-path (collection-path "help"))]
|
||||
[host-root (build-normal-path help-path "web-root")]
|
||||
[servlet-root help-path]
|
||||
[make-host-config
|
||||
(λ (file-root)
|
||||
`(host-table
|
||||
(default-indices "index.html" "index.htm")
|
||||
(log-format parenthesized-default)
|
||||
(messages
|
||||
(servlet-message "servlet-error.html")
|
||||
(authentication-message "forbidden.html")
|
||||
(servlets-refreshed "servlet-refresh.html")
|
||||
(passwords-refreshed "passwords-refresh.html")
|
||||
(file-not-found-message "not-found.html")
|
||||
(protocol-message "protocol-error.html")
|
||||
(collect-garbage "collect-garbage.html"))
|
||||
(timeouts
|
||||
(default-servlet-timeout 12000)
|
||||
(password-connection-timeout 3000)
|
||||
(servlet-connection-timeout 864000)
|
||||
(file-per-byte-connection-timeout 10)
|
||||
(file-base-connection-timeout 30000))
|
||||
(paths
|
||||
(configuration-root "conf")
|
||||
(host-root ,host-root)
|
||||
(log-file-path #f)
|
||||
(file-root ,file-root)
|
||||
(servlet-root ,servlet-root)
|
||||
(mime-types "../../web-server/default-web-root/mime.types")
|
||||
(password-authentication "passwords"))))])
|
||||
(configuration-table-sexpr->web-config@
|
||||
`((port ,(internal-port))
|
||||
(max-waiting 40)
|
||||
(initial-connection-timeout 30)
|
||||
(default-host-table
|
||||
,(make-host-config (find-collects-dir)))
|
||||
(virtual-host-table
|
||||
,@(map
|
||||
(lambda (virtual-host dir)
|
||||
`(,virtual-host
|
||||
,(make-host-config dir)))
|
||||
(cons planet-host (append doc-hosts collects-hosts))
|
||||
(cons (PLANET-DIR) (append doc-dirs collects-dirs)))))
|
||||
#:make-servlet-namespace
|
||||
(make-make-servlet-namespace
|
||||
#:to-be-copied-module-specs
|
||||
'((lib "options.ss" "help" "private")))))))
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
(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?))]))
|
||||
|
|
@ -1,79 +0,0 @@
|
|||
(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))))
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
(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?))))
|
||||
|
|
@ -1,652 +0,0 @@
|
|||
#lang scheme/unit
|
||||
(require (lib "framework.ss" "framework")
|
||||
(lib "mred.ss" "mred")
|
||||
|
||||
(lib "class.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "file.ss")
|
||||
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "external.ss" "browser")
|
||||
|
||||
(lib "browser-sig.ss" "browser")
|
||||
(lib "url-sig.ss" "net")
|
||||
(lib "url-structs.ss" "net")
|
||||
(lib "uri-codec.ss" "net")
|
||||
"sig.ss"
|
||||
"../bug-report.ss"
|
||||
(lib "bday.ss" "framework" "private")
|
||||
|
||||
"standard-urls.ss"
|
||||
"docpos.ss"
|
||||
"manuals.ss"
|
||||
"get-help-url.ss"
|
||||
|
||||
"internal-hp.ss")
|
||||
|
||||
(import browser^ url^)
|
||||
(export gui^)
|
||||
|
||||
(define help-desk-frame<%>
|
||||
(interface (frame:standard-menus<%>)
|
||||
order-manuals
|
||||
get-language-name
|
||||
change-search-to-status
|
||||
set-search-status-contents
|
||||
change-status-to-search))
|
||||
|
||||
(define bug-report/help-desk-mixin
|
||||
(mixin (frame:standard-menus<%>) ()
|
||||
(define/override (file-menu:create-open-recent?) #f)
|
||||
(define/override (help-menu:about-string)
|
||||
(string-constant plt:hd:about-help-desk))
|
||||
(define/override (help-menu:about-callback i e)
|
||||
(message-box (string-constant plt:hd:about-help-desk)
|
||||
(format
|
||||
(string-constant plt:hd:help-desk-about-string)
|
||||
(version:version) 1995 2007)
|
||||
this))
|
||||
(define/override (help-menu:create-about?) #t)
|
||||
(define/override (help-menu:after-about menu)
|
||||
(make-object menu-item% (string-constant plt:hd:help-on-help) menu
|
||||
(lambda (i e)
|
||||
(message-box
|
||||
(string-constant plt:hd:help-on-help)
|
||||
(string-constant plt:hd:help-on-help-details)
|
||||
this)))
|
||||
(new menu-item%
|
||||
(label (string-constant bug-report-submit-menu-item))
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(help-desk:report-bug)))))
|
||||
(super-new)))
|
||||
|
||||
(define (browser-scroll-frame-mixin %)
|
||||
(class %
|
||||
(inherit get-hyper-panel)
|
||||
|
||||
(define/override (on-subwindow-char w e)
|
||||
(or (let ([txt (send (send (get-hyper-panel) get-canvas) get-editor)])
|
||||
(and txt
|
||||
(let ([km (send txt get-hyper-keymap)])
|
||||
(send km handle-key-event txt e))))
|
||||
(super on-subwindow-char w e)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
;; redirect urls to outside pages to external browsers (depending on the preferences settings)
|
||||
;; also catches links into documentation that isn't installed yet and sends that
|
||||
;; to the missing manuals page.
|
||||
(define make-catch-url-frame-mixin
|
||||
(let ()
|
||||
(define (catch-url-hyper-panel-mixin %)
|
||||
(class %
|
||||
(define/override (get-canvas%)
|
||||
(catch-url-canvas-mixin (super get-canvas%)))
|
||||
(super-new)))
|
||||
|
||||
(define (catch-url-canvas-mixin %)
|
||||
(class %
|
||||
|
||||
(define/override (get-editor%) (hd-editor-mixin (super get-editor%)))
|
||||
|
||||
(define/override (remap-url url)
|
||||
(cond
|
||||
[(url? url)
|
||||
(cond
|
||||
|
||||
;; .plt files are always internal, no matter where from
|
||||
;; they will be caught elsewhere.
|
||||
[(and (url-path url)
|
||||
(not (null? (url-path url)))
|
||||
(regexp-match #rx".plt$" (path/param-path (car (last-pair (url-path url))))))
|
||||
url]
|
||||
|
||||
;; files on download.plt-scheme.org in /doc are considered
|
||||
;; things that we should view in the browser itself.
|
||||
[(is-download.plt-scheme.org/doc-url? url)
|
||||
url]
|
||||
|
||||
;; one of the "collects" hosts:
|
||||
[(and (equal? (internal-port) (url-port url))
|
||||
(ormap (lambda (host)
|
||||
(equal? host (url-host url)))
|
||||
doc-hosts))
|
||||
;; Two things can go wrong with the URL:
|
||||
;; 1. The corresponding doc might not be installed
|
||||
;; 2. There's a relative reference from X to Y, and
|
||||
;; X and Y are installed in different directories,
|
||||
;; so the host is wrong for Y
|
||||
;; Resolve 2, then check 1.
|
||||
(let* ([path (url-path url)]
|
||||
[manual (and (pair? path)
|
||||
(path/param-path (car path)))])
|
||||
(if manual
|
||||
;; Find out where this manual is really located:
|
||||
(let* ([path (find-doc-directory (string->path manual))]
|
||||
[real-url (and path
|
||||
(get-help-url path))]
|
||||
[url (if real-url
|
||||
;; Use the actual host:
|
||||
(make-url (url-scheme url)
|
||||
(url-user url)
|
||||
(url-host (string->url real-url))
|
||||
(url-port url)
|
||||
(url-path-absolute? url)
|
||||
(url-path url)
|
||||
(url-query url)
|
||||
(url-fragment url))
|
||||
;; Can't do better than the original URL?
|
||||
;; The manual is not installed.
|
||||
url)])
|
||||
(if (or (not path)
|
||||
(not (has-index-installed? path)))
|
||||
;; Manual not installed...
|
||||
(let ([doc-pr (assoc (string->path manual) known-docs)])
|
||||
(unless doc-pr
|
||||
(error 'remap-url
|
||||
"Internal error: manual ~s not found in known-docs"
|
||||
manual))
|
||||
(string->url
|
||||
(make-missing-manual-url manual
|
||||
(cdr doc-pr)
|
||||
(url->string url))))
|
||||
;; Manual here; use revised URL
|
||||
url))
|
||||
;; Not a manual? Shouldn't happen.
|
||||
url))]
|
||||
|
||||
;; one of the other internal hosts
|
||||
[(and (equal? (internal-port) (url-port url))
|
||||
(is-internal-host? (url-host url)))
|
||||
url]
|
||||
|
||||
;; send the url off to another browser
|
||||
[(and (string? (url-scheme url))
|
||||
(not (member (url-scheme url) '("http"))))
|
||||
(send-url (url->string url))
|
||||
#f]
|
||||
[(preferences:get 'drscheme:help-desk:ask-about-external-urls)
|
||||
(case (ask-user-about-separate-browser)
|
||||
[(separate)
|
||||
(send-url (url->string url))
|
||||
#f]
|
||||
[(internal)
|
||||
url]
|
||||
[else #f])]
|
||||
[(preferences:get 'drscheme:help-desk:separate-browser)
|
||||
(send-url (url->string url))
|
||||
#f]
|
||||
[else url])]
|
||||
[else url]))
|
||||
(super-new)))
|
||||
|
||||
;; has-index-installed? : path -> boolean
|
||||
(define (has-index-installed? path)
|
||||
(and (get-index-file path) #t))
|
||||
|
||||
(define sk-bitmap #f)
|
||||
|
||||
(define hd-editor-mixin
|
||||
(mixin (hyper-text<%> editor<%>) ()
|
||||
(define/augment (url-allows-evaling? url)
|
||||
(and (is-internal-host? (url-host url))
|
||||
(equal? (internal-port) (url-port url))))
|
||||
|
||||
(define show-sk? #t)
|
||||
|
||||
(define/override (on-event evt)
|
||||
(cond
|
||||
[(and show-sk?
|
||||
(sk-bday?)
|
||||
(send evt button-down? 'right))
|
||||
(let ([admin (get-admin)])
|
||||
(let ([menu (new popup-menu%)])
|
||||
(new menu-item%
|
||||
(parent menu)
|
||||
(label (string-constant happy-birthday-shriram))
|
||||
(callback (lambda (x y)
|
||||
(set! show-sk? #f)
|
||||
(let ([wb (box 0)]
|
||||
[hb (box 0)]
|
||||
[xb (box 0)]
|
||||
[yb (box 0)])
|
||||
(send admin get-view xb yb wb hb)
|
||||
(send admin needs-update (unbox xb) (unbox yb) (unbox wb) (unbox hb))))))
|
||||
(send (get-canvas) popup-menu menu
|
||||
(+ (send evt get-x) 1)
|
||||
(+ (send evt get-y) 1))))]
|
||||
[else (super on-event evt)]))
|
||||
|
||||
|
||||
(inherit dc-location-to-editor-location get-admin)
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(when before?
|
||||
(when (and show-sk? (sk-bday?))
|
||||
(unless sk-bitmap
|
||||
(set! sk-bitmap (make-object bitmap% (build-path (collection-path "icons") "sk.jpg"))))
|
||||
|
||||
(let ([admin (get-admin)])
|
||||
(when admin
|
||||
(let*-values ([(view-w view-h) (get-view-w/h admin)]
|
||||
[(view-x view-y)
|
||||
(values (- (/ view-w 2) (/ (send sk-bitmap get-width) 2))
|
||||
(- view-h (send sk-bitmap get-height)))]
|
||||
;; note: view coordinates are not exactly canvas dc coordinates
|
||||
;; but they are off by a fixed amount (same on all platforms)
|
||||
;; (note: dc-location in this method means canvas dc, which is
|
||||
;; different from the dc coming in here (offscreen bitmaps))
|
||||
[(editor-x editor-y) (dc-location-to-editor-location view-x view-y)]
|
||||
[(dc-x dc-y) (values (+ editor-x dx)
|
||||
(+ editor-y dy))])
|
||||
(send dc draw-bitmap sk-bitmap dc-x dc-y)))))))
|
||||
(define/private (get-view-w/h admin)
|
||||
(let ([wb (box 0)]
|
||||
[hb (box 0)])
|
||||
(send admin get-view #f #f wb hb)
|
||||
(values (unbox wb)
|
||||
(unbox hb))))
|
||||
|
||||
(inherit get-canvas)
|
||||
(define/override (init-browser-status-line top-level-window)
|
||||
(send top-level-window change-search-to-status))
|
||||
(define/override (update-browser-status-line top-level-window s)
|
||||
(send top-level-window set-search-status-contents s))
|
||||
(define/override (close-browser-status-line top-level-window)
|
||||
(send top-level-window change-status-to-search))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(lambda (%)
|
||||
(class %
|
||||
(define/override (get-hyper-panel%)
|
||||
(catch-url-hyper-panel-mixin (super get-hyper-panel%)))
|
||||
(super-new)))))
|
||||
|
||||
(define (is-download.plt-scheme.org/doc-url? url)
|
||||
(and (equal? "download.plt-scheme.org" (url-host url))
|
||||
(not (null? (url-path url)))
|
||||
(equal? (path/param-path (car (url-path url))) "doc")))
|
||||
|
||||
;; ask-user-about-separate-browser : -> (union #f 'separate 'internal)
|
||||
(define (ask-user-about-separate-browser)
|
||||
(define separate-default? (preferences:get 'drscheme:help-desk:separate-browser))
|
||||
|
||||
(let-values ([(result checked?)
|
||||
(message+check-box/custom
|
||||
(string-constant help-desk)
|
||||
(string-constant plt:hd:ask-about-separate-browser)
|
||||
(string-constant dont-ask-again-always-current)
|
||||
(string-constant plt:hd:homebrew-browser)
|
||||
(string-constant plt:hd:separate-browser)
|
||||
(string-constant cancel)
|
||||
#f ; no parent
|
||||
(cons
|
||||
(if separate-default?
|
||||
'default=2
|
||||
'default=1)
|
||||
'(no-default)))])
|
||||
(when checked?
|
||||
(preferences:set 'drscheme:help-desk:ask-about-external-urls #f))
|
||||
(case result
|
||||
[(2)
|
||||
(preferences:set 'drscheme:help-desk:separate-browser #t)
|
||||
'separate]
|
||||
[(1)
|
||||
(preferences:set 'drscheme:help-desk:separate-browser #f)
|
||||
'internal]
|
||||
[(#f 3)
|
||||
#f]
|
||||
[else (error 'ack)])))
|
||||
|
||||
(define make-help-desk-framework-mixin
|
||||
(mixin (frame:searchable<%> frame:standard-menus<%>) ()
|
||||
(define/override (get-text-to-search)
|
||||
(send (send (send this get-hyper-panel) get-canvas) get-editor))
|
||||
|
||||
(define/override (file-menu:create-new?) #t)
|
||||
(define/override (file-menu:new-callback x y) (new-help-desk))
|
||||
|
||||
(define/override (file-menu:create-open-recent?) #f)
|
||||
|
||||
(define/override (file-menu:create-open?) #f)
|
||||
(define/override (file-menu:create-print?) #t)
|
||||
|
||||
(define/override (file-menu:print-callback x y)
|
||||
(let ([ed (send (send (send this get-hyper-panel) get-canvas) get-editor)])
|
||||
(and ed
|
||||
(send ed print))))
|
||||
|
||||
(define/override (file-menu:between-open-and-revert file-menu)
|
||||
(super file-menu:between-open-and-revert file-menu)
|
||||
(instantiate menu:can-restore-menu-item% ()
|
||||
(parent file-menu)
|
||||
(callback (lambda (_1 _2) (open-url-callback)))
|
||||
(label (string-constant open-url...)))
|
||||
(instantiate menu:can-restore-menu-item% ()
|
||||
(parent file-menu)
|
||||
(label (string-constant reload))
|
||||
(callback (lambda (_1 _2) (send (send this get-hyper-panel) reload)))))
|
||||
|
||||
(define/private (open-url-callback)
|
||||
(let ([url (get-url-from-user this)])
|
||||
(when url
|
||||
(let* ([hp (send this get-hyper-panel)]
|
||||
[hc (send hp get-canvas)])
|
||||
(send hc goto-url url #f)))))
|
||||
|
||||
(define/override (on-size w h)
|
||||
(preferences:set 'drscheme:help-desk:frame-width w)
|
||||
(preferences:set 'drscheme:help-desk:frame-height h)
|
||||
(super on-size w h))
|
||||
|
||||
(super-new
|
||||
(width (preferences:get 'drscheme:help-desk:frame-width))
|
||||
(height (preferences:get 'drscheme:help-desk:frame-height)))
|
||||
|
||||
(frame:reorder-menus this)))
|
||||
|
||||
(define make-search-button-mixin
|
||||
(mixin (frame:basic<%> hyper-frame<%>) ()
|
||||
(field [search-panel #f])
|
||||
|
||||
;; order-manuals : as in drscheme:language:language<%>
|
||||
;; by default, search in all manuals
|
||||
(define/public (order-manuals x) (values x #t))
|
||||
|
||||
;; the name of the language to put in the top of the search results,
|
||||
;; or #f if nothing is to be put there.
|
||||
(define/public (get-language-name) #f)
|
||||
|
||||
(define/override (make-root-area-container class parent)
|
||||
(let* ([search-panel-parent (super make-root-area-container vertical-panel% parent)]
|
||||
[main-panel (make-object class search-panel-parent)])
|
||||
(set! search-panel (instantiate vertical-panel% ()
|
||||
(parent search-panel-parent)
|
||||
(stretchable-height #f)))
|
||||
main-panel))
|
||||
|
||||
;; these methods have the same name as the methods in the browser.
|
||||
;; they are called during super initialization, so they protect themselves...
|
||||
(define/public (change-search-to-status)
|
||||
(when search/status-panel
|
||||
(send search/status-panel active-child status-panel)))
|
||||
(define/public (set-search-status-contents s)
|
||||
(when status-message
|
||||
(send status-message set-label (trim-string 200 s))))
|
||||
(define/private (trim-string n str)
|
||||
(cond
|
||||
[(<= (string-length str) n) str]
|
||||
[else (string-append (substring str 0 98)
|
||||
" ... "
|
||||
(substring str (- (string-length str)
|
||||
97)
|
||||
(string-length str)))]))
|
||||
|
||||
(define/public (change-status-to-search)
|
||||
(when search/status-panel
|
||||
(send search/status-panel active-child field-panel)
|
||||
(send search-field focus)))
|
||||
|
||||
(field [search/status-panel #f]
|
||||
[field-panel #f]
|
||||
[search-field #f]
|
||||
[status-panel #f]
|
||||
[status-message #f]
|
||||
[choices-panel #f])
|
||||
|
||||
(super-new (label (string-constant help-desk)))
|
||||
|
||||
(let ([hp (send this get-hyper-panel)])
|
||||
(send hp set-init-page home-page-url)
|
||||
(send (send hp get-canvas) allow-tab-exit #t))
|
||||
|
||||
(inherit get-menu-bar get-hyper-panel)
|
||||
(let ()
|
||||
(define search-menu (instantiate menu% ()
|
||||
(label (string-constant plt:hd:search))
|
||||
(parent (get-menu-bar))))
|
||||
(define search-menu-item (instantiate menu:can-restore-menu-item% ()
|
||||
(label (string-constant plt:hd:search))
|
||||
(parent search-menu)
|
||||
(shortcut #\e)
|
||||
(callback
|
||||
(lambda (x y) (search-callback #f)))))
|
||||
(define lucky-menu-item (instantiate menu:can-restore-menu-item% ()
|
||||
(label (string-constant plt:hd:feeling-lucky))
|
||||
(parent search-menu)
|
||||
(shortcut #\u)
|
||||
(callback
|
||||
(lambda (x y) (search-callback #t)))))
|
||||
(define stupid-internal-define-syntax1
|
||||
(set! search/status-panel (new panel:single%
|
||||
(parent search-panel)
|
||||
(stretchable-width #t))))
|
||||
(define stupid-internal-define-syntax2
|
||||
(set! field-panel (new horizontal-panel% (parent search/status-panel))))
|
||||
(define stupid-internal-define-syntax3
|
||||
(set! status-panel (new horizontal-panel% (parent search/status-panel))))
|
||||
(define stupid-internal-define-syntax4
|
||||
(set! status-message (new message%
|
||||
(parent status-panel)
|
||||
(stretchable-width #t)
|
||||
(label ""))))
|
||||
(define stupid-internal-define-syntax5
|
||||
(set! search-field (instantiate text-field% ()
|
||||
(label (string-constant plt:hd:find-docs-for))
|
||||
(callback (lambda (x y)
|
||||
(let ([on? (not (equal? "" (send search-field get-value)))])
|
||||
(send search-button enable on?)
|
||||
(send search-menu enable on?))))
|
||||
(parent field-panel))))
|
||||
|
||||
;; exposed to derived classes
|
||||
(define stupid-internal-define-syntax6
|
||||
(set! choices-panel (instantiate horizontal-panel% ()
|
||||
(parent search-panel)
|
||||
(alignment '(center center)))))
|
||||
|
||||
(define search-button (instantiate button% ()
|
||||
(label (string-constant plt:hd:search))
|
||||
(parent field-panel)
|
||||
(callback (lambda (x y) (search-callback #f)))
|
||||
(style '(border))))
|
||||
(define search-where (instantiate choice% ()
|
||||
(label #f)
|
||||
(parent choices-panel)
|
||||
(selection (preferences:get 'drscheme:help-desk:search-where))
|
||||
(choices
|
||||
(list
|
||||
(string-constant plt:hd:search-for-keyword)
|
||||
(string-constant plt:hd:search-for-keyword-or-index)
|
||||
(string-constant plt:hd:search-for-keyword-or-index-or-text)))
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(preferences:set 'drscheme:help-desk:search-where
|
||||
(send search-where get-selection))))))
|
||||
(define search-how (instantiate choice% ()
|
||||
(label #f)
|
||||
(parent choices-panel)
|
||||
(selection (preferences:get 'drscheme:help-desk:search-how))
|
||||
(choices
|
||||
(list
|
||||
(string-constant plt:hd:exact-match)
|
||||
(string-constant plt:hd:containing-match)
|
||||
(string-constant plt:hd:regexp-match)))
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(preferences:set 'drscheme:help-desk:search-how
|
||||
(send search-how get-selection))))))
|
||||
|
||||
(define grow-box-spacer (make-object grow-box-spacer-pane% choices-panel))
|
||||
(define (search-callback lucky?)
|
||||
(let-values ([(manuals doc.txt?) (order-manuals (map path->bytes (map car (find-doc-names))))])
|
||||
(let ([url (make-results-url
|
||||
(send search-field get-value)
|
||||
(case (send search-where get-selection)
|
||||
[(0) "keyword"]
|
||||
[(1) "keyword-index"]
|
||||
[(2) "keyword-index-text"])
|
||||
(case (send search-how get-selection)
|
||||
[(0) "exact-match"]
|
||||
[(1) "containing-match"]
|
||||
[(2) "regexp-match"])
|
||||
lucky?
|
||||
(map bytes->path manuals)
|
||||
doc.txt?
|
||||
(get-language-name))])
|
||||
(send (send (get-hyper-panel) get-canvas) goto-url url #f))))
|
||||
|
||||
(send search-button enable #f)
|
||||
(send search-menu enable #f)
|
||||
(send search-field focus))))
|
||||
|
||||
(define help-desk-frame-mixin #f)
|
||||
(define addl-mixins (lambda (x) x))
|
||||
(define (add-help-desk-mixin m)
|
||||
(if help-desk-frame-mixin
|
||||
(error 'add-help-desk-mixin "help desk frame has already been created")
|
||||
(set! addl-mixins (compose m addl-mixins))))
|
||||
(define (make-help-desk-frame-mixin)
|
||||
(or help-desk-frame-mixin
|
||||
(begin
|
||||
(set! help-desk-frame-mixin
|
||||
(compose
|
||||
addl-mixins
|
||||
(lambda (x) (class* x (help-desk-frame<%>) (super-new)))
|
||||
make-catch-url-frame-mixin
|
||||
bug-report/help-desk-mixin
|
||||
make-help-desk-framework-mixin
|
||||
browser-scroll-frame-mixin
|
||||
frame:searchable-mixin
|
||||
frame:standard-menus-mixin
|
||||
make-search-button-mixin))
|
||||
help-desk-frame-mixin)))
|
||||
|
||||
(define new-help-desk
|
||||
(opt-lambda ([link home-page-url])
|
||||
(let ([f (new ((make-help-desk-frame-mixin) hyper-no-show-frame%))])
|
||||
(send f show #t)
|
||||
(goto-url link f)
|
||||
f)))
|
||||
|
||||
(define (goto-hd-location sym)
|
||||
(let ([loc (get-hd-location sym)])
|
||||
(goto-url loc)))
|
||||
|
||||
(define (goto-manual-link manual index-key)
|
||||
(goto-url (prefix-with-server (finddoc-page-anchor manual index-key))))
|
||||
|
||||
(define (search-for-docs search-string search-type match-type lucky? docs)
|
||||
(let ([fr (or (find-help-desk-frame)
|
||||
(new-help-desk))])
|
||||
(search-for-docs/in-frame fr search-string search-type match-type lucky? docs)))
|
||||
|
||||
(define (search-for-docs/in-frame fr search-string search-type match-type lucky? docs)
|
||||
(send fr show #t)
|
||||
(let-values ([(manuals doc.txt?) (send fr order-manuals (map path->bytes docs))])
|
||||
(goto-url (make-results-url search-string
|
||||
search-type
|
||||
match-type
|
||||
lucky?
|
||||
(map bytes->path manuals)
|
||||
doc.txt?
|
||||
(send fr get-language-name))
|
||||
fr)))
|
||||
|
||||
(define goto-url
|
||||
(opt-lambda (link [fr (find-help-desk-frame)])
|
||||
(if fr
|
||||
(send (send (send fr get-hyper-panel) get-canvas) goto-url link #f)
|
||||
(new-help-desk link))))
|
||||
|
||||
(define (show-help-desk)
|
||||
(let ([fr (find-help-desk-frame)])
|
||||
(if fr
|
||||
(send fr show #t)
|
||||
(new-help-desk))))
|
||||
|
||||
(define (find-help-desk-frame)
|
||||
(let loop ([frames (send (group:get-the-frame-group) get-frames)])
|
||||
(cond
|
||||
[(null? frames) #f]
|
||||
[else (let ([frame (car frames)])
|
||||
(if (is-a? frame help-desk-frame<%>)
|
||||
frame
|
||||
(loop (cdr frames))))])))
|
||||
|
||||
(define (get-url-from-user parent)
|
||||
(define d (make-object dialog% (string-constant open-url) parent 500))
|
||||
(define t
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% (string-constant url:) d
|
||||
(lambda (t e)
|
||||
(update-ok))))))
|
||||
(define p (make-object horizontal-panel% d))
|
||||
(define browse (make-object button% (string-constant browse...) p
|
||||
(lambda (b e)
|
||||
(let ([f (get-file)])
|
||||
(when f
|
||||
(send t set-value (encode-file-path-as-url f))
|
||||
(update-ok))))))
|
||||
|
||||
(define (encode-file-path-as-url f)
|
||||
(apply
|
||||
string-append
|
||||
"file:"
|
||||
(map
|
||||
(λ (x) (string-append "/" (uri-path-segment-encode (path->string x))))
|
||||
(explode-path f))))
|
||||
|
||||
(define spacer (make-object vertical-pane% p))
|
||||
(define result #f)
|
||||
(define (ok-callback b e)
|
||||
(let* ([s (send t get-value)]
|
||||
[done (lambda ()
|
||||
;; Might be called twice!
|
||||
(preferences:set 'drscheme:help-desk:last-url-string s)
|
||||
(send d show #f))])
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (x)
|
||||
(message-box (string-constant bad-url)
|
||||
(format (string-constant bad-url:this)
|
||||
(exn-message x))
|
||||
d))])
|
||||
(let* ([removed-spaces (regexp-replace #rx"^[ \t]*" s "")]
|
||||
[str (cond
|
||||
[(regexp-match #rx":" removed-spaces) removed-spaces]
|
||||
[(regexp-match #rx"^[a-zA-Z][a-zA-Z.]*($|/)" removed-spaces)
|
||||
(string-append "http://" removed-spaces)]
|
||||
[else
|
||||
(string-append "file:" removed-spaces)])]
|
||||
|
||||
;; just convert the string to test it out; don't use result...
|
||||
[url (string->url str)])
|
||||
(set! result str)
|
||||
(done)))))
|
||||
(define cancel-callback (lambda (b e) (send d show #f)))
|
||||
(define-values (ok cancel)
|
||||
(gui-utils:ok/cancel-buttons
|
||||
p
|
||||
ok-callback
|
||||
cancel-callback))
|
||||
(define (update-ok)
|
||||
(send ok enable
|
||||
(positive? (send (send t get-editor)
|
||||
last-position))))
|
||||
(define last-url-string (preferences:get 'drscheme:help-desk:last-url-string))
|
||||
(when last-url-string
|
||||
(send t set-value last-url-string)
|
||||
(let ([text (send t get-editor)])
|
||||
(send text set-position 0 (send text last-position))))
|
||||
(send p set-alignment 'right 'center)
|
||||
(update-ok)
|
||||
(send d center)
|
||||
(send t focus)
|
||||
(send d show #t)
|
||||
result)
|
||||
|
|
@ -1,120 +0,0 @@
|
|||
(module installed-components mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "getinfo.ss" "setup")
|
||||
(lib "uri-codec.ss" "net")
|
||||
(lib "util.ss" "help" "servlets" "private"))
|
||||
|
||||
(provide help-desk:installed-components)
|
||||
|
||||
;; comp = (make-comp string xexpr)
|
||||
;; this represents a collection with a blurb field.
|
||||
;; the name names the collection and the xml is its xexpr blurb
|
||||
(define-struct comp (name xml))
|
||||
|
||||
;; help-desk:installed-components url : -> (listof (list string xexpr))
|
||||
;; represents all of the collections with blurb fields
|
||||
(define (help-desk:installed-components)
|
||||
(let ([comps
|
||||
(sort (filter (lambda (x) x)
|
||||
(map (lambda (c) (get-blurb c)) (all-collections)))
|
||||
comp<=?)])
|
||||
(map comp-xml comps)))
|
||||
|
||||
;; all-collections : -> (lisof string)
|
||||
;; returns a list of the collections from the current-library-collections-path parameter
|
||||
(define (all-collections)
|
||||
(let ([colls (make-hash-table 'equal)])
|
||||
(for-each
|
||||
(lambda (collection-path-dir)
|
||||
(when (directory-exists? collection-path-dir)
|
||||
(for-each
|
||||
(lambda (collection)
|
||||
(when (and (directory-exists? (build-path collection-path-dir collection))
|
||||
(not (member (path->bytes collection) '(#"CVS" #".svn"))))
|
||||
(hash-table-put! colls collection #t)))
|
||||
(directory-list collection-path-dir))))
|
||||
(current-library-collection-paths))
|
||||
(sort (hash-table-map colls (lambda (x v) x))
|
||||
(lambda (x y) (string<=? (path->string x) (path->string y))))))
|
||||
|
||||
;; get-blurb : string url -> xexpr
|
||||
;; builds the xexpr for a collection, based on its name a blurb
|
||||
(define (get-blurb collection)
|
||||
(let/ec k
|
||||
(let ([proc (with-handlers ([(lambda (x) (not (exn:break? x)))
|
||||
(lambda (x) #f)])
|
||||
(get-info (list collection)))])
|
||||
(unless proc
|
||||
(k #f))
|
||||
(let* ([name (with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(k
|
||||
(make-comp
|
||||
collection
|
||||
`(li
|
||||
(font ((color "forestgreen")) (b () ,collection))
|
||||
(p
|
||||
(font
|
||||
((color "red"))
|
||||
(i ,(format "error during 'name: ~a"
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
x)))))))))])
|
||||
(proc 'name (lambda () (k #f))))]
|
||||
[blurb (with-handlers ([(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(k
|
||||
(make-comp
|
||||
collection
|
||||
`(li
|
||||
(font ((color "forestgreen")) (b () ,name))
|
||||
(br)
|
||||
(font ((color "red"))
|
||||
(i
|
||||
,(format "error during 'blurb: ~a"
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
x))))))))])
|
||||
(proc 'blurb (lambda () (k #f))))]
|
||||
[blurb-ok? (andmap xexpr? blurb)])
|
||||
(make-comp
|
||||
name
|
||||
`(li
|
||||
(font ((color "forest green"))
|
||||
(b ,name))
|
||||
(br)
|
||||
,@(append
|
||||
(if blurb-ok?
|
||||
blurb
|
||||
(list `(font ((color "red"))
|
||||
"blurb was not a list of xexprs")))
|
||||
(let ([fname (build-path (collection-path collection) "doc.txt")])
|
||||
(if (file-exists? fname)
|
||||
(list
|
||||
" See "
|
||||
`(A ((HREF ,(format
|
||||
"/servlets/doc-anchor.ss?file=~a&caption=Documentation for the ~a collection&name=~a"
|
||||
(uri-encode (path->string fname))
|
||||
collection
|
||||
collection)))
|
||||
"the documentation")
|
||||
" for more information.")
|
||||
null)))))))))
|
||||
|
||||
;; build-string-from-comp : comp -> string
|
||||
;; constructs a string version of the xexpr from a comp
|
||||
(define (build-string-from-comp comp)
|
||||
(let ([blurb (comp-xml comp)]
|
||||
[p (open-output-string)])
|
||||
(write-xml/content
|
||||
(xexpr->xml
|
||||
blurb)
|
||||
p)
|
||||
(newline p)
|
||||
(newline p)
|
||||
(get-output-string p)))
|
||||
|
||||
;; comp<=? : comp comp -> boolean
|
||||
;; compares two comps for sorting
|
||||
(define (comp<=? ca cb) (string<=? (comp-name ca) (comp-name cb))))
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
(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)))
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
(module link mzscheme
|
||||
(require (lib "web-server-unit.ss" "web-server")
|
||||
(lib "web-server-sig.ss" "web-server")
|
||||
(lib "web-config-sig.ss" "web-server")
|
||||
|
||||
(lib "unit.ss")
|
||||
|
||||
(lib "tcp-sig.ss" "net")
|
||||
(lib "url-sig.ss" "net")
|
||||
(lib "url-unit.ss" "net")
|
||||
|
||||
(lib "browser-sig.ss" "browser")
|
||||
(lib "browser-unit.ss" "browser")
|
||||
|
||||
(lib "plt-installer-sig.ss" "setup")
|
||||
(lib "plt-installer.ss" "setup")
|
||||
|
||||
(lib "mred-unit.ss" "mred")
|
||||
(lib "mred-sig.ss" "mred")
|
||||
|
||||
"tcp-intercept.ss"
|
||||
"sig.ss"
|
||||
|
||||
"gui.ss"
|
||||
"main.ss"
|
||||
"config.ss")
|
||||
|
||||
(define-unit-from-context inst@ setup:plt-installer^)
|
||||
(define-unit-from-context real-tcp@ tcp^)
|
||||
(define-unit-binding config@ (make-config) (import) (export web-config^))
|
||||
|
||||
(define-compound-unit/infer help-desk@
|
||||
(import)
|
||||
(export gui^ main^ web-server^)
|
||||
(link inst@
|
||||
standard-mred@
|
||||
(((real-tcp : tcp^)) real-tcp@)
|
||||
config@
|
||||
(((real-url : url^)) url@ real-tcp)
|
||||
(() web-server@ real-tcp)
|
||||
(((ic-tcp : tcp^)) tcp-intercept@)
|
||||
(((pre-ic-url : url^)) url@ ic-tcp)
|
||||
(((ic-url : url^)) url-intercept@ pre-ic-url)
|
||||
(() browser@ ic-tcp ic-url)
|
||||
(() gui@ ic-url)
|
||||
main@))
|
||||
|
||||
(define-values/invoke-unit/infer help-desk@)
|
||||
|
||||
(provide-signature-elements gui^ main^ web-server^))
|
||||
|
|
@ -1,168 +0,0 @@
|
|||
#lang scheme/unit
|
||||
(require (lib "framework.ss" "framework")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "external.ss" "browser")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "htmltext.ss" "browser")
|
||||
(prefix home: "../servlets/home.ss")
|
||||
"sig.ss")
|
||||
|
||||
(import)
|
||||
(export main^)
|
||||
|
||||
;; where should the pref stuff really go?
|
||||
(preferences:set-default 'drscheme:help-desk:last-url-string "" string?)
|
||||
(preferences:set-default 'drscheme:help-desk:frame-width 350 number?)
|
||||
(preferences:set-default 'drscheme:help-desk:frame-height 400 number?)
|
||||
(preferences:set-default 'drscheme:help-desk:search-how 1 (lambda (x) (member x '(0 1 2))))
|
||||
(preferences:set-default 'drscheme:help-desk:search-where 1 (lambda (x) (member x '(0 1 2))))
|
||||
|
||||
(preferences:set-default 'drscheme:help-desk:separate-browser #t boolean?)
|
||||
(preferences:set-default 'drscheme:help-desk:ask-about-external-urls #t boolean?)
|
||||
|
||||
(preferences:set-default 'drscheme:help-desk:font-size
|
||||
(cons #f
|
||||
(let* ([txt (make-object text%)]
|
||||
[stl (send txt get-style-list)]
|
||||
[bcs (send stl basic-style)])
|
||||
(send bcs get-size)))
|
||||
(λ (x)
|
||||
(and (pair? x)
|
||||
(boolean? (car x))
|
||||
(and (integer? (cdr x))
|
||||
(<= 0 (cdr x) 255)))))
|
||||
|
||||
;; create "Html Standard" style to be able to
|
||||
;; adjust its size in the preferences dialog
|
||||
(let* ([sl (editor:get-standard-style-list)]
|
||||
[html-standard-style-delta (make-object style-delta% 'change-nothing)]
|
||||
[html-standard-style
|
||||
(send sl find-or-create-style
|
||||
(send sl find-named-style "Standard")
|
||||
html-standard-style-delta)])
|
||||
(send sl new-named-style "Html Standard" html-standard-style))
|
||||
|
||||
(preferences:add-callback
|
||||
'drscheme:help-desk:font-size
|
||||
(λ (k v) (update-font-size v)))
|
||||
|
||||
(define (update-font-size v)
|
||||
(let ([style (send (editor:get-standard-style-list) find-named-style "Html Standard")])
|
||||
(send style set-delta
|
||||
(if (car v)
|
||||
(make-object style-delta% 'change-size (cdr v))
|
||||
(make-object style-delta% 'change-nothing)))))
|
||||
(update-font-size (preferences:get 'drscheme:help-desk:font-size))
|
||||
|
||||
(add-to-browser-prefs-panel
|
||||
(lambda (panel)
|
||||
(let* ([cbp (instantiate group-box-panel% ()
|
||||
(parent panel)
|
||||
(label (string-constant plt:hd:external-link-in-help))
|
||||
(alignment '(left center))
|
||||
(stretchable-height #f)
|
||||
(style '(deleted)))]
|
||||
[cb (instantiate check-box% ()
|
||||
(label (string-constant plt:hd:use-homebrew-browser))
|
||||
(parent cbp)
|
||||
(value (not (preferences:get 'drscheme:help-desk:separate-browser)))
|
||||
(callback
|
||||
(lambda (cb evt)
|
||||
(preferences:set 'drscheme:help-desk:separate-browser
|
||||
(not (send cb get-value))))))])
|
||||
;; Put checkbox panel at the top:
|
||||
(send panel change-children (lambda (l) (cons cbp l)))
|
||||
(preferences:add-callback
|
||||
'drscheme:help-desk:separate-browser
|
||||
(lambda (p v) (send cb set-value (not v))))
|
||||
(void))))
|
||||
|
||||
(define (add-help-desk-font-prefs show-example?)
|
||||
(preferences:add-panel
|
||||
(list (string-constant font-prefs-panel-title)
|
||||
(string-constant help-desk))
|
||||
(lambda (panel)
|
||||
(let* ([vp (new vertical-panel% (parent panel) (alignment '(left top)))]
|
||||
[use-drs (new check-box%
|
||||
(label (string-constant use-drscheme-font-size))
|
||||
(parent vp)
|
||||
(value (not (car (preferences:get 'drscheme:help-desk:font-size))))
|
||||
(callback
|
||||
(λ (cb y)
|
||||
(preferences:set 'drscheme:help-desk:font-size
|
||||
(cons (not (send cb get-value))
|
||||
(cdr (preferences:get
|
||||
'drscheme:help-desk:font-size)))))))]
|
||||
[size (new slider%
|
||||
(label (string-constant font-size))
|
||||
(min-value 1)
|
||||
(max-value 255)
|
||||
(parent vp)
|
||||
(callback
|
||||
(λ (size evt)
|
||||
(preferences:set 'drscheme:help-desk:font-size
|
||||
(cons
|
||||
#t
|
||||
(send size get-value)))))
|
||||
(init-value
|
||||
(cdr (preferences:get 'drscheme:help-desk:font-size))))]
|
||||
[hp (new horizontal-panel%
|
||||
(alignment '(center center))
|
||||
(stretchable-height #f)
|
||||
(parent vp))]
|
||||
[mk-button
|
||||
(λ (label func)
|
||||
(new button%
|
||||
(parent hp)
|
||||
(label label)
|
||||
(callback
|
||||
(λ (k v)
|
||||
(let ([old (preferences:get 'drscheme:help-desk:font-size)])
|
||||
(preferences:set 'drscheme:help-desk:font-size
|
||||
(cons (car old)
|
||||
(func (cdr old)))))))))]
|
||||
[sub1-button (mk-button "-1" sub1)]
|
||||
[add1-button (mk-button "+1" add1)]
|
||||
[enable/disable
|
||||
(λ (v)
|
||||
(send size enable (car v))
|
||||
(send sub1-button enable (car v))
|
||||
(send add1-button enable (car v))
|
||||
(send size set-value (cdr v)))])
|
||||
(preferences:add-callback
|
||||
'drscheme:help-desk:font-size
|
||||
(λ (k v)
|
||||
(enable/disable v)))
|
||||
(enable/disable (preferences:get 'drscheme:help-desk:font-size))
|
||||
|
||||
(when show-example?
|
||||
(let* ([show-message
|
||||
(λ ()
|
||||
(message-box
|
||||
(string-constant help-desk)
|
||||
(string-constant help-desk-this-is-just-example-text)))]
|
||||
[mix
|
||||
(λ (%)
|
||||
(class %
|
||||
(inherit set-clickback)
|
||||
(define/override (add-link p1 p2 s)
|
||||
(set-clickback p1 p2 (lambda (e x y) (show-message))))
|
||||
(define/override (add-thunk-callback p1 p2 thunk)
|
||||
(set-clickback p1 p2 (lambda (e p1 p2) (show-message))))
|
||||
(define/override (add-scheme-callback p1 p2 scheme)
|
||||
(set-clickback p1 p2 (lambda (e p1 p2) (show-message))))
|
||||
(super-new)))]
|
||||
[text (new (mix (html-text-mixin (text:hide-caret/selection-mixin
|
||||
text:standard-style-list%))))]
|
||||
[msg (new message% (parent vp) (label (string-constant example-text)))]
|
||||
[ec (new editor-canvas% (parent vp) (editor text))])
|
||||
(let-values ([(in out) (make-pipe)])
|
||||
(thread
|
||||
(λ ()
|
||||
(write-xml/content (xexpr->xml (home:start #f)) out)
|
||||
(close-output-port out)))
|
||||
(render-html-to-text in text #f #t))))
|
||||
|
||||
vp))))
|
||||
|
|
@ -1,380 +0,0 @@
|
|||
(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?))]))
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
(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))
|
||||
|
||||
)
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
(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?)]))
|
||||
|
||||
|
|
@ -1,604 +0,0 @@
|
|||
(module search mzscheme
|
||||
(require (lib "string-constant.ss" "string-constants")
|
||||
"colldocs.ss"
|
||||
"path.ss"
|
||||
"manuals.ss"
|
||||
(lib "port.ss")
|
||||
(lib "getinfo.ss" "setup")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "dirs.ss" "setup"))
|
||||
|
||||
(provide doc-collections-changed
|
||||
reset-doc-lists
|
||||
extract-doc-txt
|
||||
load-txt-keywords-into-hash-table)
|
||||
(provide/contract
|
||||
[do-search
|
||||
(string?
|
||||
number?
|
||||
boolean?
|
||||
boolean?
|
||||
(listof path?)
|
||||
boolean?
|
||||
any/c
|
||||
(-> any)
|
||||
(string? any/c . -> . void?)
|
||||
(string? any/c . -> . void?)
|
||||
(string? string? string? path? (or/c string? number? false/c) any/c . -> . void?)
|
||||
. -> .
|
||||
(or/c string? false/c))]
|
||||
|
||||
(build-string-finds/finds (string?
|
||||
boolean?
|
||||
boolean?
|
||||
. -> .
|
||||
(values (listof string?)
|
||||
(listof (or/c regexp? string?)))))
|
||||
|
||||
(non-regexp (string? . -> . string?)))
|
||||
|
||||
(define doc-dirs (get-doc-search-dirs))
|
||||
|
||||
; These are set by reset-doc-lists:
|
||||
; docs, doc-names and doc-kinds are parallel lists. doc-kinds
|
||||
; distinguishes between the two variants of docs.
|
||||
; docs : (list-of (union string (list path string)))
|
||||
(define docs null)
|
||||
; doc-names : (list-of string)
|
||||
(define doc-names null)
|
||||
; doc-kinds : (list-of symbol)
|
||||
(define doc-kinds null)
|
||||
; doc-collection-date : (union #f number 'none)
|
||||
(define doc-collection-dates (map (lambda (x) #f) doc-dirs))
|
||||
|
||||
(define (dir-date/none dir)
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (x) 'none)])
|
||||
(file-or-directory-modify-seconds dir)))
|
||||
|
||||
(define (reset-doc-lists)
|
||||
; Locate standard HTML documentation
|
||||
(define-values (std-docs std-doc-names)
|
||||
(let* ([docs (find-doc-directories)]
|
||||
[doc-names (map get-doc-name docs)])
|
||||
(values docs doc-names)))
|
||||
|
||||
; Check collections for doc.txt files:
|
||||
(define-values (txt-docs txt-doc-names) (colldocs))
|
||||
|
||||
(set! docs (append std-docs txt-docs))
|
||||
|
||||
(set! doc-names (append
|
||||
std-doc-names
|
||||
(map (lambda (s) (format "the ~a" s))
|
||||
txt-doc-names)))
|
||||
(set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))
|
||||
|
||||
(set! doc-collection-dates (map dir-date/none doc-dirs)))
|
||||
|
||||
(define MAX-HIT-COUNT 300)
|
||||
|
||||
(define (clean-html s)
|
||||
(regexp-replace*
|
||||
"&[^;]*;"
|
||||
(regexp-replace*
|
||||
"<[^>]*>"
|
||||
(regexp-replace*
|
||||
"&"
|
||||
(regexp-replace*
|
||||
">"
|
||||
(regexp-replace*
|
||||
"<"
|
||||
s
|
||||
"<")
|
||||
">")
|
||||
"\\&")
|
||||
"")
|
||||
""))
|
||||
|
||||
(define (with-hash-table ht key compute)
|
||||
(hash-table-get
|
||||
ht
|
||||
key
|
||||
(lambda ()
|
||||
(let ([v (compute)])
|
||||
(hash-table-put! ht key v)
|
||||
v))))
|
||||
|
||||
(define html-keywords (make-hash-table 'equal))
|
||||
(define (load-html-keywords doc)
|
||||
(with-hash-table
|
||||
html-keywords
|
||||
doc
|
||||
(lambda ()
|
||||
(transform-keywords
|
||||
(build-path doc "keywords")))))
|
||||
|
||||
(define html-indices (make-hash-table 'equal))
|
||||
(define (load-html-index doc)
|
||||
(with-hash-table
|
||||
html-indices
|
||||
doc
|
||||
(lambda ()
|
||||
(transform-hdindex
|
||||
(build-path doc "hdindex")))))
|
||||
|
||||
;; transform-hdindex : any -> (listof (list string path string string)
|
||||
;; makes sure the input from the file is well-formed and changes
|
||||
;; the bytes to paths.
|
||||
(define (transform-hdindex filename)
|
||||
(verify-file filename
|
||||
(λ (l)
|
||||
(match l
|
||||
[`(,(? string? index)
|
||||
,(? string? file)
|
||||
,(? string? label)
|
||||
,(? string? title))
|
||||
#t]
|
||||
[else
|
||||
#f]))))
|
||||
|
||||
;; transform-keywords : any -> (listof (list string string path string string)
|
||||
;; as with transform-hdindex
|
||||
(define (transform-keywords filename)
|
||||
(verify-file filename
|
||||
(λ (l)
|
||||
(match l
|
||||
[`(,(? string? keyword)
|
||||
,(? string? result)
|
||||
,(? path-string? file)
|
||||
,(? string? label)
|
||||
,(? string? title))
|
||||
#t]
|
||||
[else
|
||||
#f]))))
|
||||
|
||||
(define (verify-file filename ele-ok?)
|
||||
(let/ec k
|
||||
(let ([fail (lambda (why)
|
||||
(fprintf (current-error-port)
|
||||
"loading docs from ~a failed: ~a\n"
|
||||
(path->string filename)
|
||||
why)
|
||||
(k '()))])
|
||||
(with-handlers ([exn:fail:read? (lambda (x)
|
||||
(fail
|
||||
(format "read error when opening the file ~a"
|
||||
(exn-message x))))]
|
||||
[exn:fail:filesystem?
|
||||
(lambda (x)
|
||||
(fail (format
|
||||
"filesystem error when opening the file ~a"
|
||||
(exn-message x))))])
|
||||
(let ([l (if (file-exists? filename)
|
||||
(call-with-input-file filename read)
|
||||
'())])
|
||||
(unless (list? l) (fail "not a list"))
|
||||
(for-each (lambda (l)
|
||||
(unless (ele-ok? l)
|
||||
(fail (format "line ~s is malformed" l))))
|
||||
l)
|
||||
l)))))
|
||||
|
||||
(define (parse-txt-file doc ht handle-parsing)
|
||||
(with-hash-table
|
||||
ht
|
||||
doc
|
||||
(lambda ()
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (x) null)])
|
||||
(call-with-input-file doc
|
||||
handle-parsing)))))
|
||||
|
||||
(define re:keyword-line (regexp "\n>"))
|
||||
(define text-keywords (make-hash-table 'equal))
|
||||
|
||||
(define (load-txt-keywords doc)
|
||||
(load-txt-keywords-into-hash-table text-keywords doc))
|
||||
|
||||
(define (load-txt-keywords-into-hash-table ht doc)
|
||||
(parse-txt-file
|
||||
(apply build-path doc)
|
||||
ht
|
||||
(λ (p)
|
||||
(port-count-lines! p)
|
||||
(let loop ()
|
||||
(let ([m (regexp-match re:keyword-line p)])
|
||||
(cond
|
||||
[m
|
||||
(let/ec k
|
||||
(let* ([peek-port (let-values ([(line col pos) (port-next-location p)])
|
||||
(let ([pp (peeking-input-port p)])
|
||||
(port-count-lines! pp)
|
||||
(let ([rp (relocate-input-port pp line col pos)])
|
||||
(port-count-lines! rp)
|
||||
rp)))]
|
||||
[entry (parameterize ([read-accept-bar-quote #f])
|
||||
(with-handlers ([exn:fail:read?
|
||||
(lambda (x)
|
||||
(fprintf (current-error-port)
|
||||
"found > on line ~a in ~s that did not parse properly\n first-line: ~a\n exn-msg: ~a\n"
|
||||
(let-values ([(line col pos) (port-next-location p)])
|
||||
line)
|
||||
(path->string (apply build-path doc))
|
||||
(read-line (peeking-input-port p))
|
||||
(exn-message x))
|
||||
(k null))])
|
||||
(read peek-port)))]
|
||||
[key (let loop ([l-entry entry])
|
||||
(cond
|
||||
[(symbol? l-entry) l-entry]
|
||||
[(keyword? l-entry) l-entry]
|
||||
[(pair? l-entry) (if (and (eq? (car l-entry) 'quote)
|
||||
(pair? (cdr l-entry)))
|
||||
(loop (cadr l-entry))
|
||||
(loop (car l-entry)))]
|
||||
[else (fprintf (current-error-port) "load-txt-keyword: bad entry in ~s: ~s\n" doc entry)
|
||||
#f]))]
|
||||
[content (if (symbol? entry)
|
||||
(with-handlers ([exn:fail:read? (lambda (x) #f)])
|
||||
(let ([s (read peek-port)])
|
||||
(if (eq? s '::)
|
||||
(format "~s ~s ~s" entry s (read peek-port))
|
||||
#f)))
|
||||
#f)]
|
||||
[txt-to-display
|
||||
(let ([p (open-output-string)])
|
||||
(if content
|
||||
(display content p)
|
||||
(if (and (pair? entry)
|
||||
(pair? (cdr entry))
|
||||
(eq? (car entry) 'quote))
|
||||
(fprintf p "'~s" (cadr entry))
|
||||
(display entry p)))
|
||||
(get-output-string p))]
|
||||
[kwd-entry
|
||||
(and key
|
||||
; Make the keyword entry:
|
||||
(list (format "~s" key) ; the keyword name
|
||||
txt-to-display ; the text to display
|
||||
(cadr doc) ; file
|
||||
(let-values ([(line col pos) (port-next-location p)])
|
||||
(- pos 2)) ; label (a position in this case)
|
||||
"doc.txt"))])
|
||||
(if kwd-entry
|
||||
(cons kwd-entry (loop))
|
||||
(loop))))] ; title
|
||||
[else null]))))))
|
||||
|
||||
(define re:index-line (regexp "_([^_]*)_(.*)"))
|
||||
(define text-indices (make-hash-table 'equal))
|
||||
(define (load-txt-index doc)
|
||||
(parse-txt-file
|
||||
(apply build-path doc)
|
||||
text-indices
|
||||
(λ (p)
|
||||
(let loop ([start 0])
|
||||
(let* ([r (read-line p 'any)]
|
||||
[next (if (eof-object? r)
|
||||
start
|
||||
(+ start (string-length r) 1))])
|
||||
(cond
|
||||
[(eof-object? r) null]
|
||||
[(regexp-match re:index-line r)
|
||||
=>
|
||||
(lambda (m)
|
||||
(append (let loop ([m m])
|
||||
(let ([s (cadr m)])
|
||||
(cons
|
||||
; Make an index entry:
|
||||
(cons s start)
|
||||
(let ([m (regexp-match re:index-line (caddr m))])
|
||||
(if m
|
||||
(loop m)
|
||||
null)))))
|
||||
(loop next)))]
|
||||
[else (loop next)]))))))
|
||||
|
||||
(define re:splitter (regexp "^ *([^ ]+)(.*)"))
|
||||
(define (split-words s)
|
||||
(let ([m (regexp-match re:splitter s)])
|
||||
(if m
|
||||
(cons (cadr m)
|
||||
(split-words (caddr m)))
|
||||
null)))
|
||||
|
||||
;; non-regexp : string -> string
|
||||
(define (non-regexp s)
|
||||
(list->string
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (c)
|
||||
(cond
|
||||
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
|
||||
(list #\\ c)]
|
||||
[(char-alphabetic? c)
|
||||
(list #\[ (char-upcase c) (char-downcase c) #\])]
|
||||
[else (list c)]))
|
||||
(string->list s)))))
|
||||
|
||||
(define (doc-collections-changed)
|
||||
(reset-relevant-directories-state!)
|
||||
(reset-doc-lists)
|
||||
(set! doc-collection-dates (map (lambda (x) #f) doc-dirs))
|
||||
(set! html-keywords (make-hash-table 'equal))
|
||||
(set! html-indices (make-hash-table 'equal))
|
||||
(set! text-keywords (make-hash-table 'equal))
|
||||
(set! text-indices (make-hash-table 'equal)))
|
||||
|
||||
(define max-reached #f)
|
||||
|
||||
(define (build-string-finds/finds given-find regexp? exact?)
|
||||
(cond
|
||||
[exact? (values (list given-find)
|
||||
(list given-find))]
|
||||
[regexp? (values (list given-find)
|
||||
(list (regexp given-find)))]
|
||||
[else (let ([wl (split-words given-find)])
|
||||
(values wl
|
||||
(map regexp (map non-regexp wl))))]))
|
||||
|
||||
; do-search : (string ; the search text, unprocessed
|
||||
; num ; 0 = keyword, 1 = keyword+index, 2 = all text
|
||||
; boolean ; #t if string should be used as a regexp
|
||||
; boolean ; #t if the string should match exactly (not just "contains")
|
||||
; (listof path) ; the manuals to search
|
||||
; boolean ; #t if the doc.txt files should be searched
|
||||
; value ; arbitrary key supplied to the "add" functions
|
||||
; (-> A) ; called when more than enough are found; must escape
|
||||
; (string value -> void) ; called to output a document section header (e.g., a manual name)
|
||||
; (symbol value -> void) ; called to output a document-kind section header, 'text or 'html
|
||||
; (string string string path (union string #f) value -> void)
|
||||
; ^ ^ ^ ^ ^- label within page
|
||||
; ^ ^ ^ ^- path to doc page
|
||||
; ^ ^ ^- source doc title
|
||||
; ^ ^- display label
|
||||
; ^- found entry's key
|
||||
; ->
|
||||
; (union string #f))
|
||||
(define (do-search given-find search-level regexp? exact? manuals doc-txt?
|
||||
ckey maxxed-out
|
||||
add-doc-section add-kind-section add-choice)
|
||||
; When new docs are installed, the directory's modification date changes:
|
||||
(set! max-reached #f)
|
||||
|
||||
(when (ormap (lambda (date new-date)
|
||||
(cond
|
||||
[(not date) #t]
|
||||
[(equal? date new-date) #f]
|
||||
[(eq? date 'none) #t]
|
||||
[(eq? new-date 'none) #t]
|
||||
[else (new-date . > . date)]))
|
||||
doc-collection-dates
|
||||
(map dir-date/none doc-dirs))
|
||||
(reset-doc-lists))
|
||||
|
||||
(let ([hit-count 0])
|
||||
(let-values ([(string-finds finds) (build-string-finds/finds given-find regexp? exact?)]
|
||||
[(filtered-docs filtered-doc-names filtered-doc-kinds)
|
||||
(filter-docs manuals doc-txt?)])
|
||||
(for-each
|
||||
(lambda (doc doc-name doc-kind)
|
||||
(define found-one #f)
|
||||
(define (found kind)
|
||||
(unless found-one
|
||||
(add-doc-section doc-name ckey))
|
||||
(unless (equal? found-one kind)
|
||||
(set! found-one kind)
|
||||
(add-kind-section kind ckey))
|
||||
(set! hit-count (add1 hit-count))
|
||||
(unless (< hit-count MAX-HIT-COUNT)
|
||||
(maxxed-out)))
|
||||
|
||||
; Keyword search
|
||||
(let ([keys (case doc-kind
|
||||
[(html) (load-html-keywords doc)]
|
||||
[(text) (load-txt-keywords doc)]
|
||||
[else null])]
|
||||
[add-key-choice (lambda (v)
|
||||
(when (and (pair? v)
|
||||
(pair? (cdr v))
|
||||
(pair? (cddr v))
|
||||
(pair? (cdddr v))
|
||||
(pair? (cddddr v)))
|
||||
(found "keyword entries")
|
||||
(add-choice
|
||||
(car v) ; key
|
||||
(cadr v) ; display
|
||||
(list-ref v 4) ; title
|
||||
(if (eq? 'text doc-kind)
|
||||
(apply build-path doc)
|
||||
(let ([file (bytes->path
|
||||
(string->bytes/utf-8
|
||||
(list-ref v 2)))])
|
||||
(if (servlet-path? file)
|
||||
file
|
||||
(build-path doc file))))
|
||||
(list-ref v 3) ; label
|
||||
ckey)))])
|
||||
|
||||
(unless regexp?
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(when (string=? given-find (car v))
|
||||
(add-key-choice v)))
|
||||
keys))
|
||||
(unless (or exact? (null? finds))
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(when (andmap (lambda (find) (regexp-match find (car v))) finds)
|
||||
(unless (and (not regexp?) (string=? given-find (car v)))
|
||||
(add-key-choice v))))
|
||||
keys)))
|
||||
|
||||
; Index search
|
||||
(unless (< search-level 1)
|
||||
(let ([index (case doc-kind
|
||||
[(html) (load-html-index doc)]
|
||||
[(text) (load-txt-index doc)]
|
||||
[else null])]
|
||||
[add-index-choice (lambda (name desc)
|
||||
(case doc-kind
|
||||
[(html)
|
||||
(when (and (pair? desc)
|
||||
(pair? (cdr desc))
|
||||
(pair? (cddr desc)))
|
||||
(found "index entries")
|
||||
(add-choice
|
||||
"" name
|
||||
(list-ref desc 2)
|
||||
(let ([filename (bytes->path (string->bytes/utf-8 (list-ref desc 0)))])
|
||||
(if (servlet-path? filename)
|
||||
filename
|
||||
(build-path doc filename)))
|
||||
(list-ref desc 1)
|
||||
ckey))]
|
||||
[(text)
|
||||
(found "index entries")
|
||||
(add-choice
|
||||
"" name
|
||||
"indexed content"
|
||||
(apply build-path doc)
|
||||
desc
|
||||
ckey)]))])
|
||||
(when index
|
||||
(unless regexp?
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(when (string=? given-find (car v))
|
||||
(add-index-choice (car v) (cdr v))))
|
||||
index))
|
||||
(unless (or exact? (null? finds))
|
||||
(for-each
|
||||
(lambda (v)
|
||||
(when (andmap (lambda (find) (regexp-match find (car v))) finds)
|
||||
(unless (and (not regexp?) (string=? given-find (car v)))
|
||||
(add-index-choice (car v) (cdr v)))))
|
||||
index)))))
|
||||
|
||||
; Content Search
|
||||
(unless (or (< search-level 2) exact? (null? finds))
|
||||
(let ([files (case doc-kind
|
||||
[(html) (with-handlers ([exn:fail:filesystem? (lambda (x) null)])
|
||||
(map (lambda (x) (build-path doc x))
|
||||
(filter
|
||||
(lambda (x)
|
||||
(let ([str (path->string x)])
|
||||
(cond
|
||||
[(or (regexp-match "--h\\.idx$" str)
|
||||
(regexp-match "--h\\.ind$" str)
|
||||
(regexp-match "Z-A\\.scm$" str)
|
||||
(regexp-match "Z-L\\.scm$" str)
|
||||
(regexp-match "gif$" str)
|
||||
(regexp-match "png$" str)
|
||||
(regexp-match "hdindex$" str)
|
||||
(regexp-match "keywords$" str))
|
||||
#f]
|
||||
[else
|
||||
(file-exists? (build-path doc x))])))
|
||||
(directory-list doc))))]
|
||||
[(text) (list (apply build-path doc))]
|
||||
[else null])])
|
||||
(for-each
|
||||
(lambda (f)
|
||||
(with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
||||
(with-input-from-file f
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(let ([pos (file-position (current-input-port))]
|
||||
[r (read-line)])
|
||||
(unless (eof-object? r)
|
||||
(let ([m (andmap (lambda (find) (regexp-match find r)) finds)])
|
||||
(when m
|
||||
(found "text")
|
||||
(add-choice (car m)
|
||||
; Strip leading space and clean HTML
|
||||
(regexp-replace
|
||||
"^ [ ]*"
|
||||
(if (eq? doc-kind 'html)
|
||||
(clean-html r)
|
||||
r)
|
||||
"")
|
||||
"content"
|
||||
f
|
||||
(if (eq? doc-kind 'text) pos "NO TAG")
|
||||
ckey)))
|
||||
(loop))))))))
|
||||
files))))
|
||||
filtered-docs filtered-doc-names filtered-doc-kinds)
|
||||
|
||||
(if (= 0 hit-count)
|
||||
(format (string-constant plt:hd:nothing-found-for)
|
||||
(if (null? string-finds)
|
||||
""
|
||||
(apply
|
||||
string-append
|
||||
(cons (format "\"~a\"" (car string-finds))
|
||||
(map (lambda (i) (format " ~a \"~a\"" (string-constant plt:hd:and) i))
|
||||
(cdr string-finds))))))
|
||||
#f))))
|
||||
|
||||
;; filter-docs : (listof path) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist])
|
||||
;; given the list of manuals specified by `manuals', returns the sublists of the global
|
||||
;; variables docs, doc-names, and doc-kinds that make sense for this search.
|
||||
(define (filter-docs manuals doc-txt?)
|
||||
(let loop ([manuals manuals])
|
||||
(cond
|
||||
[(null? manuals) (if doc-txt?
|
||||
(extract-doc-txt)
|
||||
(values null null null))]
|
||||
[else (let ([man (car manuals)])
|
||||
(let-values ([(r-doc r-doc-names r-doc-kinds) (loop (cdr manuals))]
|
||||
[(t-doc t-doc-names t-doc-kinds) (find-doc man)])
|
||||
(if t-doc
|
||||
(values (cons t-doc r-doc)
|
||||
(cons t-doc-names r-doc-names)
|
||||
(cons t-doc-kinds r-doc-kinds))
|
||||
(values r-doc
|
||||
r-doc-names
|
||||
r-doc-kinds))))])))
|
||||
|
||||
;; find-doc :
|
||||
;; path -> (values doc[element of docs] doc-name[element of doc-names] doc-kind[element of doc-kinds])
|
||||
(define (find-doc man)
|
||||
(let loop ([x-docs docs]
|
||||
[x-doc-names doc-names]
|
||||
[x-doc-kinds doc-kinds])
|
||||
(cond
|
||||
[(and (null? x-docs) (null? x-doc-names) (null? x-doc-kinds))
|
||||
(values #f #f #f)]
|
||||
[(or (null? x-docs) (null? x-doc-names) (null? x-doc-kinds))
|
||||
(error 'find-doc "mismatched lists\n")]
|
||||
[else
|
||||
(let ([doc (car x-docs)])
|
||||
(cond
|
||||
[(eq? 'html (car x-doc-kinds))
|
||||
(let-values ([(base name dir?) (split-path doc)])
|
||||
(cond
|
||||
[(equal? man name)
|
||||
(values doc (car x-doc-names) (car x-doc-kinds))]
|
||||
[else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))]
|
||||
[else (loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))]))])))
|
||||
|
||||
;; extract-doc-txt : (listof string) boolean -> (values docs[sublist] doc-names[sublist] doc-kinds[sublist])
|
||||
;; returns the manuals that are not 'html.
|
||||
(define (extract-doc-txt)
|
||||
(let loop ([x-docs docs]
|
||||
[x-doc-names doc-names]
|
||||
[x-doc-kinds doc-kinds])
|
||||
(cond
|
||||
[(null? x-docs) (values null null null)]
|
||||
[(or (null? x-doc-names) (null? x-doc-kinds))
|
||||
(error 'extract-doc-txt "mismatched lists\n")]
|
||||
[else
|
||||
(if (eq? (car x-doc-kinds) 'html)
|
||||
(loop (cdr x-docs) (cdr x-doc-names) (cdr x-doc-kinds))
|
||||
(let-values ([(r-docs r-doc-names r-doc-kinds) (loop (cdr x-docs)
|
||||
(cdr x-doc-names)
|
||||
(cdr x-doc-kinds))])
|
||||
(values (cons (car x-docs) r-docs)
|
||||
(cons (car x-doc-names) r-doc-names)
|
||||
(cons (car x-doc-kinds) r-doc-kinds))))]))))
|
||||
|
||||
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
(module sig mzscheme
|
||||
(require (lib "unit.ss"))
|
||||
(provide gui^
|
||||
main^)
|
||||
|
||||
(define-signature main^
|
||||
(add-help-desk-font-prefs))
|
||||
|
||||
(define-signature gui^
|
||||
(help-desk-frame<%>
|
||||
add-help-desk-mixin
|
||||
new-help-desk
|
||||
find-help-desk-frame
|
||||
show-help-desk
|
||||
goto-hd-location
|
||||
goto-manual-link
|
||||
search-for-docs
|
||||
search-for-docs/in-frame)))
|
||||
|
|
@ -1,134 +0,0 @@
|
|||
(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?)]))
|
||||
|
|
@ -1,117 +0,0 @@
|
|||
(module tcp-intercept mzscheme
|
||||
(provide tcp-intercept@ url-intercept@)
|
||||
|
||||
(require (lib "unit.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "web-server-sig.ss" "web-server")
|
||||
(lib "tcp-sig.ss" "net")
|
||||
(lib "url-sig.ss" "net")
|
||||
"internal-hp.ss")
|
||||
|
||||
(define-syntax (redefine stx)
|
||||
(syntax-case stx ()
|
||||
[(_ names ...)
|
||||
(with-syntax ([(defs ...) (map (lambda (x)
|
||||
(with-syntax ([orig-name x]
|
||||
[raw-name
|
||||
(datum->syntax-object
|
||||
x
|
||||
(string->symbol
|
||||
(string-append
|
||||
"raw:"
|
||||
(symbol->string (syntax-object->datum x)))))])
|
||||
(syntax (define orig-name raw-name))))
|
||||
(syntax->list (syntax (names ...))))])
|
||||
(syntax (begin defs ...)))]))
|
||||
|
||||
(define-unit url-intercept@ (import (prefix raw: url^)) (export url^)
|
||||
(init-depend url^)
|
||||
(redefine url->string
|
||||
get-pure-port
|
||||
get-impure-port
|
||||
post-pure-port
|
||||
post-impure-port
|
||||
head-pure-port
|
||||
head-impure-port
|
||||
put-pure-port
|
||||
put-impure-port
|
||||
delete-pure-port
|
||||
delete-impure-port
|
||||
display-pure-port
|
||||
purify-port
|
||||
netscape/string->url
|
||||
string->url
|
||||
call/input-url
|
||||
combine-url/relative
|
||||
url-exception?
|
||||
current-proxy-servers))
|
||||
|
||||
(define raw:tcp-abandon-port tcp-abandon-port)
|
||||
(define raw:tcp-accept tcp-accept)
|
||||
(define raw:tcp-accept/enable-break tcp-accept/enable-break)
|
||||
(define raw:tcp-accept-ready? tcp-accept-ready?)
|
||||
(define raw:tcp-addresses tcp-addresses)
|
||||
(define raw:tcp-close tcp-close)
|
||||
(define raw:tcp-connect tcp-connect)
|
||||
(define raw:tcp-connect/enable-break tcp-connect/enable-break)
|
||||
(define raw:tcp-listen tcp-listen)
|
||||
(define raw:tcp-listener? tcp-listener?)
|
||||
|
||||
; For tcp-listeners, we use an else branch in the conds since
|
||||
; (instead of a contract) I want the same error message as the raw
|
||||
; primitive for bad inputs.
|
||||
|
||||
; : (listof nat) -> (unit/sig () -> net:tcp^)
|
||||
(define-unit tcp-intercept@ (import web-server^) (export tcp^)
|
||||
|
||||
; : port -> void
|
||||
(define (tcp-abandon-port tcp-port)
|
||||
(cond
|
||||
[(tcp-port? tcp-port)
|
||||
(raw:tcp-abandon-port tcp-port)]
|
||||
[(input-port? tcp-port)
|
||||
(close-input-port tcp-port)]
|
||||
[(output-port? tcp-port)
|
||||
(close-output-port tcp-port)]
|
||||
[else (void)]))
|
||||
|
||||
; : listener -> iport oport
|
||||
(define tcp-accept raw:tcp-accept)
|
||||
; : listener -> iport oport
|
||||
(define tcp-accept/enable-break raw:tcp-accept/enable-break)
|
||||
|
||||
; : tcp-listener -> iport oport
|
||||
(define tcp-accept-ready? raw:tcp-accept-ready?)
|
||||
|
||||
; : tcp-port -> str str
|
||||
(define (tcp-addresses tcp-port)
|
||||
(if (tcp-port? tcp-port)
|
||||
(raw:tcp-addresses tcp-port)
|
||||
(values "127.0.0.1" internal-host)))
|
||||
|
||||
; : port -> void
|
||||
(define tcp-close raw:tcp-close)
|
||||
|
||||
; : (str nat -> iport oport) -> str nat -> iport oport
|
||||
(define (gen-tcp-connect raw)
|
||||
(lambda (hostname-string port)
|
||||
(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)])
|
||||
(parameterize ([current-custodian (make-custodian)])
|
||||
(serve-ports req-in resp-out))
|
||||
(values resp-in req-out))
|
||||
(raw hostname-string port))))
|
||||
|
||||
; : str nat -> iport oport
|
||||
(define tcp-connect (gen-tcp-connect raw:tcp-connect))
|
||||
|
||||
; : str nat -> iport oport
|
||||
(define tcp-connect/enable-break (gen-tcp-connect raw:tcp-connect/enable-break))
|
||||
|
||||
; FIX - support the reuse? flag.
|
||||
(define tcp-listen raw:tcp-listen)
|
||||
|
||||
; : tst -> bool
|
||||
(define tcp-listener? raw:tcp-listener?)))
|
||||
|
|
@ -1,232 +0,0 @@
|
|||
(module refresh-manuals mzscheme
|
||||
(require "private/docpos.ss"
|
||||
"private/search.ss"
|
||||
"private/manuals.ss"
|
||||
"private/standard-urls.ss"
|
||||
"private/link.ss"
|
||||
(lib "plt-installer.ss" "setup")
|
||||
(lib "url.ss" "net")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "contract.ss")
|
||||
(lib "port.ss")
|
||||
(lib "thread.ss"))
|
||||
|
||||
(provide refresh-manuals
|
||||
bytes-to-path)
|
||||
|
||||
|
||||
(define sc-refreshing-manuals (string-constant plt:hd:refreshing-manuals))
|
||||
(define sc-refresh-downloading... (string-constant plt:hd:refresh-downloading...))
|
||||
(define sc-refresh-deleting... (string-constant plt:hd:refresh-deleting...))
|
||||
(define sc-refresh-installing... (string-constant plt:hd:refresh-installing...))
|
||||
(define sc-finished-installation (string-constant plt:hd:refreshing-manuals-finished))
|
||||
(define sc-clearing-cached-indicies (string-constant plt:hd:refresh-clearing-indicies))
|
||||
|
||||
(define refresh-manuals
|
||||
(case-lambda
|
||||
[() (refresh-manuals known-docs)]
|
||||
[(docs-to-install)
|
||||
(unless (and (list? docs-to-install)
|
||||
(andmap (lambda (x) (and (pair? x)
|
||||
(path? (car x))
|
||||
(string? (cdr x))))
|
||||
docs-to-install))
|
||||
(error 'refresh-manuals "expected (listof (cons path string)) as argument, got ~e" docs-to-install))
|
||||
(let ([tmp-directory (find/create-temporary-docs-dir)]
|
||||
[success? #f]
|
||||
[thd #f])
|
||||
(with-installer-window
|
||||
(lambda (parent)
|
||||
(set! thd (current-thread))
|
||||
(unless tmp-directory
|
||||
(error 'plt-installer "please clean out ~a" (find-system-path 'temp-dir)))
|
||||
(let ([docs-error (download-docs docs-to-install tmp-directory)])
|
||||
(cond
|
||||
[docs-error
|
||||
(printf "~a\n" docs-error)]
|
||||
[else
|
||||
(delete-docs docs-to-install)
|
||||
(install-docs docs-to-install tmp-directory parent)
|
||||
(delete-local-plt-files tmp-directory)
|
||||
(display sc-clearing-cached-indicies)
|
||||
(newline)
|
||||
|
||||
;; tell the web-server to visit the url for flushing the cache
|
||||
;; this is necc. because the server creates a new namespace for
|
||||
;; each servlet, so we have to get the webserver to visit the servlet
|
||||
;; in order to flush the cache. We don't, however, want to actually
|
||||
;; visit the page, so we just do this for its effect.
|
||||
(let-values ([(in1 out1) (make-pipe)]
|
||||
[(in2 out2) (make-pipe)])
|
||||
(thread (lambda ()
|
||||
(fprintf out1 "GET ~a HTTP/1.0\r\n" flush-manuals-path)
|
||||
(close-output-port out1)))
|
||||
(serve-ports in1 out2) ;; spawns its own thread
|
||||
(let loop ()
|
||||
(let ([b (with-handlers ([exn? (lambda (x) eof)])
|
||||
(read-byte in2))])
|
||||
(unless (eof-object? b)
|
||||
(loop))))
|
||||
(close-input-port in2))])
|
||||
|
||||
(display sc-finished-installation)
|
||||
(newline)
|
||||
(set! success? #t)))
|
||||
(lambda ()
|
||||
(unless success?
|
||||
(delete-local-plt-files tmp-directory))
|
||||
(kill-thread thd))))]))
|
||||
|
||||
; needed in "../private/manuals.ss" due to links with > getting mangled
|
||||
(define bytes-to-path bytes->path)
|
||||
|
||||
(define (make-local-doc-filename tmp-dir stub)
|
||||
(build-path tmp-dir (format "~a-doc.plt" stub)))
|
||||
|
||||
;; if cannot find a suitable directory, #f is returned
|
||||
;; if okay, returns the path to the directory.
|
||||
(define find/create-temporary-docs-dir
|
||||
;(-> (union string? false?))
|
||||
(lambda ()
|
||||
(let ([temp-dir (find-system-path 'temp-dir)])
|
||||
(let loop ([n 0])
|
||||
(if (= n 30)
|
||||
#f
|
||||
(let ([candidate (build-path temp-dir (format "help-refresh-docs~a" n))])
|
||||
(if (directory-exists? candidate)
|
||||
(loop (+ n 1))
|
||||
(begin
|
||||
(make-directory candidate)
|
||||
candidate))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; ;;; ;;
|
||||
; ; ;
|
||||
; ; ;
|
||||
;;;; ;;; ;;; ;;;; ;;; ; ;;; ;;;; ;;;;
|
||||
; ; ; ; ; ; ;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
;;; ; ;;; ; ; ;;; ;; ;;;;;; ;;; ;;; ; ;;; ;
|
||||
|
||||
|
||||
|
||||
|
||||
;; download-docs : ... -> (union #f string)
|
||||
;; downloads the docs to the tmp-dir
|
||||
(define download-docs
|
||||
(lambda (docs-to-install tmp-dir)
|
||||
(let loop ([known-docs docs-to-install])
|
||||
(cond
|
||||
[(null? known-docs) #f]
|
||||
[else (let* ([known-doc (car known-docs)]
|
||||
[resp (download-doc tmp-dir (car known-doc) (cdr known-doc))])
|
||||
(if (string? resp)
|
||||
resp
|
||||
(loop (cdr known-docs))))]))))
|
||||
|
||||
;; download-doc : ... -> (union #f string)
|
||||
;; stub is the `drscheme' portion of `drscheme-doc.plt'.
|
||||
(define download-doc
|
||||
(lambda (tmp-dir stub full-name)
|
||||
(let ([url (make-docs-plt-url (path->string stub))]
|
||||
[doc-name (make-local-doc-filename tmp-dir stub)])
|
||||
(display (format sc-refresh-downloading... full-name))
|
||||
(newline)
|
||||
(call-with-output-file doc-name
|
||||
(lambda (out-port)
|
||||
(call/input-url (string->url url)
|
||||
get-impure-port
|
||||
(lambda (in-port)
|
||||
(let/ec k
|
||||
(let* ([resp (purify-port in-port)]
|
||||
[m (regexp-match #rx"HTTP/[^ ]* ([0-9]+)([^\r\n]*)" resp)])
|
||||
(unless m
|
||||
(k "malformed response from server ~s" resp))
|
||||
(let ([code (string->number (cadr m))])
|
||||
(unless (equal? code 200)
|
||||
(k (format "error response from server \"~a~a\"" code (caddr m)))))
|
||||
(copy-port in-port out-port)
|
||||
#f)))))))))
|
||||
|
||||
|
||||
|
||||
;; ;;;
|
||||
; ; ;
|
||||
; ; ;
|
||||
;;;; ;;; ; ;;; ;;;;; ;;;
|
||||
; ; ; ; ; ; ; ; ; ;
|
||||
; ; ;;;;; ; ;;;;; ; ;;;;;
|
||||
; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ;
|
||||
;;; ; ;;; ;;;;;; ;;; ;;; ;;;
|
||||
|
||||
|
||||
|
||||
(define delete-docs
|
||||
(lambda (docs)
|
||||
(for-each (lambda (known-doc) (delete-known-doc (car known-doc) (cdr known-doc)))
|
||||
docs)))
|
||||
|
||||
(define delete-known-doc
|
||||
(lambda (doc full-name)
|
||||
(let ([doc-dir (find-doc-directory doc)])
|
||||
(when doc-dir
|
||||
(display (format sc-refresh-deleting... full-name))
|
||||
(newline)
|
||||
(with-handlers ([exn:fail:filesystem?
|
||||
(lambda (exn)
|
||||
(fprintf (current-error-port)
|
||||
"Warning: delete failed: ~a\n"
|
||||
(exn-message exn)))])
|
||||
(delete-directory/r doc-dir))))))
|
||||
|
||||
(define delete-local-plt-files
|
||||
(lambda (tmp-dir)
|
||||
(delete-directory/r tmp-dir)))
|
||||
|
||||
;; deletes the entire subtree underneath this directory
|
||||
;; (including the dir itself)
|
||||
(define delete-directory/r
|
||||
(lambda (dir)
|
||||
(when (directory-exists? dir)
|
||||
(let loop ([dir dir])
|
||||
(let ([children (directory-list dir)])
|
||||
(for-each (lambda (f) (when (file-exists? (build-path dir f))
|
||||
(delete-file (build-path dir f))))
|
||||
children)
|
||||
(for-each (lambda (d) (when (directory-exists? (build-path dir d))
|
||||
(loop (build-path dir d))))
|
||||
children)
|
||||
(delete-directory dir))))))
|
||||
|
||||
|
||||
|
||||
; ;;; ;;;
|
||||
; ; ;
|
||||
; ; ;
|
||||
;;; ; ;;; ;;; ;;;;; ;;;; ; ;
|
||||
; ;; ; ; ; ; ; ; ;
|
||||
; ; ; ;;; ; ;;;; ; ;
|
||||
; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ;
|
||||
;;;;; ;;; ;; ;;; ;;; ;;; ; ;;;;;; ;;;;;;
|
||||
|
||||
|
||||
|
||||
(define install-docs
|
||||
(lambda (docs-to-install tmp-dir parent)
|
||||
(for-each (lambda (pr)
|
||||
(display (format sc-refresh-installing... (cdr pr)))
|
||||
(newline)
|
||||
(run-single-installer (make-local-doc-filename tmp-dir (car pr))
|
||||
(lambda ()
|
||||
(error 'install-docs
|
||||
"expected PLT-relative archive"))))
|
||||
docs-to-install))))
|
||||
Loading…
Reference in New Issue
Block a user