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

Merged online HelpDesk into /collects/help

Browse Source 
Most non-manual help desk pages are now in /help/servlets/home.ss
Servlets are now x-expr based instead of string based.
See instructions in /help/launch.ss if you want to try the online version.

svn: r7160
This commit is contained in:
Jens Axel Soegaard 2007-08-25 19:08:33 +00:00
parent 9c1acc89dc
commit 6d8b8a3390
28 changed files with 1449 additions and 462 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/help/help-desk.ss
View File

@ -1,6 +1,7 @@
(module help-desk mzscheme
(require
"bug-report.ss" ;; this is require'd here to get the prefs defaults setup done early.
"servlets/private/platform.ss" ;; same reason
"private/manuals.ss"
"private/buginfo.ss"
@ -9,6 +10,8 @@
"private/link.ss"
(lib "contract.ss"))
(current-helpdesk-platform 'internal-browser)
(provide help-desk-frame<%>)
(provide/contract

36
collects/help/launch.ss Normal file
View File

@ -0,0 +1,36 @@
;;; launch.ss
; 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 "collects/help/private/internal-hp.ss".
; Change the parameter current-helpdesk-platform
; in "collects/help/servlets/private/platform.ss"
; to 'external-browser when testing the online version.
; Startpage:
; http://localhost:8000/servlets/home.ss
; (where 8000 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")
; start the HelpDesk server, and store a shutdown
(define shutdown
(serve/web-config@ config))
(display "Did you remember to change current-helpdesk-platform in platform.ss?\n\n")
(display (format "Start here: http://~a:~a/servlets/home.ss\n\n"
internal-host internal-port))
(display "Press enter to shutdown.\n")
(read-line)
;(shutdown)

49
collects/help/private/colldocs.ss
View File

@ -4,41 +4,26 @@
(lib "contract.ss"))
(define (colldocs)
(let loop ([dirrecs
(sort (find-relevant-directory-records '(doc.txt) 'all-available)
(lambda (a b)
(bytes<? (path->bytes (directory-record-path a))
(path->bytes (directory-record-path b)))))]
(let loop ([dirs (sort (map path->string (find-relevant-directories
'(doc.txt) 'all-available))
string<?)]
[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)))])))
(define (pleasant-name name dirrec)
(case (car (directory-record-spec dirrec))
((lib)
(format "~a collection" name))
((planet)
(format "~a package ~s"
name
`(,@(cdr (directory-record-spec dirrec))
,(directory-record-maj dirrec)
,(directory-record-min dirrec))))))
[(null? dirs) (values (reverse docs) (reverse names))]
[else (let* ([dir (string->path (car dirs))]
[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 dirs)
(cons (list dir (string->path doc.txt-path))
docs)
(cons name names))
(loop (cdr dirs) docs names)))
(loop (cdr dirs) docs names)))])))
(provide/contract
[colldocs (-> (values (listof (list/c path? path?))

3
collects/help/private/docpos.ss
View File

@ -55,8 +55,7 @@
("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)))
("profj-advanced" "ProfessorJ Advanced Language" 212)))
(define known-docs (map (lambda (x) (cons (string->path (car x)) (cadr x))) docs-and-positions))

75
collects/help/private/finddoc.ss
View File

@ -1,8 +1,9 @@
(module finddoc mzscheme
(require "path.ss"
"get-help-url.ss"
(lib "dirs.ss" "setup"))
(require (lib "dirs.ss" "setup")
(lib "match.ss")
"path.ss"
"get-help-url.ss")
(provide finddoc
finddoc-page
finddoc-page-anchor
@ -12,25 +13,27 @@
;; The link doesn't go to a particular anchor,
;; because "file:" does not support that.
(define (finddoc manual index-key label)
(let ([m (lookup manual index-key label)])
(if (string? m)
m
(format "<A href=\"file:~a\">~a</A>"
(build-path (car m) (caddr m))
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?)
(let ([m (lookup manual index-key "dummy")])
(if (string? m)
(error (format "Error finding index \"~a\" in manual \"~a\""
index-key manual))
(if (servlet-path? (string->path (caddr m)))
(if anchor?
(string-append (caddr m) "#" (cadddr m))
(caddr m))
(get-help-url (build-path (list-ref m 0)
(list-ref m 2))
(list-ref m 3))))))
(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
@ -38,33 +41,33 @@
; /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 either a string (failure) or
;; (list docdir index-key filename anchor title)
;; 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)))))]
(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))))
(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)

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

@ -27,17 +27,18 @@
((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~a~a"
host
(format "http://~a:~a/servlets/static.ss/~a~a~a"
internal-host
internal-port
(apply string-append (map (λ (x) (format "/~a" (path->string x)))
host
(apply string-append (map (λ (x) (format "/~a" (path->string x)))
segments))
(if anchor
(string-append "#" anchor)

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

@ -9,8 +9,11 @@
;; Hostnames defined here should not exist as real machines
;; The general idea is that there's one virtual host for
;; 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).
@ -20,8 +23,8 @@
;; when cross-manual references are implemented as relative
;; URLs.)
(define internal-host "helpdesk-internal.localhost")
(define internal-port 8000)
(define internal-host "localhost")
(define internal-port 8012)
(define (is-internal-host? str)
(member str all-internal-hosts))
@ -30,10 +33,10 @@
(let loop ([dirs dirs][n 0])
(if (null? dirs)
null
(cons (format "~a~a.~a" prefix n internal-host)
(loop (cdr dirs) (add1 n))))))
(cons (format "~a~a" prefix n)
(loop (cdr dirs) (add1 n))))))
(define planet-host (format "planet.~a" internal-host))
(define planet-host "planet")
(define collects-dirs
(get-collects-search-dirs))

371
collects/help/private/manuals.ss
View File

@ -1,22 +1,20 @@
(module manuals mzscheme
(require (lib "list.ss")
(lib "date.ss")
(lib "string-constant.ss" "string-constants")
(lib "xml.ss" "xml")
(lib "xml.ss" "xml")
(lib "contract.ss")
(lib "getinfo.ss" "setup")
(lib "uri-codec.ss" "net")
(lib "dirs.ss" "setup")
"finddoc.ss"
(lib "dirs.ss" "setup")
(lib "match.ss")
"finddoc.ss"
"colldocs.ss"
"docpos.ss"
"path.ss"
"standard-urls.ss"
"get-help-url.ss"
"../servlets/private/util.ss"
"../servlets/private/headelts.ss")
"../servlets/private/util.ss")
;; type sec = (make-sec name regexp (listof regexp))
(define-struct sec (name reg seps))
@ -37,32 +35,33 @@
(make-sec "Libraries" #rx"SRFI|MzLib|Framework|PLT Miscellaneous|Teachpack|Swindle" '())
(make-sec "Writing extensions" #rx"Tools|Inside|Foreign" '())
(make-sec "Other" #rx"" '())))
; manual is doc collection subdirectory, e.g. "mred"
; 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))
[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)))
; string string string -> xexpr
; man is manual name
; ndx is index into the manual
; txt is the link text
; 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)]
@ -72,14 +71,14 @@
(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])
@ -106,7 +105,7 @@
[else
(loop (cdr dirs))]))]
[else (loop (cdr dirs))]))]))))
(define (find-doc-directories-in-toplevel-docs)
(apply append
(map (lambda (docs-path)
@ -114,11 +113,11 @@
(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))
'()))))
(filter (lambda (x)
(not (member (path->string x)
'(".svn" "CVS"))))
(directory-list docs-path))
'()))))
(get-doc-search-dirs))))
(define (find-manuals)
@ -126,81 +125,96 @@
compare-docs)]
[names (map get-doc-name docs)]
[names+paths (map cons names docs)])
(apply
string-append
"<html>"
(xexpr->string `(HEAD ,hd-css ,@hd-links (TITLE "PLT Manuals")))
"<body>"
(append
(list "<H1>Installed Manuals</H1>")
(if (repos-or-nightly-build?)
(list
"<b>Subversion:</b> <a mzscheme=\""
(to-string/escape-quotes
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)))
"\">"
(string-constant plt:hd:refresh-all-manuals)
"</a> &nbsp; &nbsp;"
(format "<a href=\"~a\">flush index and keyword cache</a><br>" flush-manuals-url))
'())
(build-known-manuals names+paths)
(list "<h3>Doc.txt</h3><ul>")
(doc.txt-manuals)
(list "</UL>")
(let ([uninstalled (get-uninstalled docs)])
(if (null? uninstalled)
`("")
`("<H3>Uninstalled Manuals</H3>"
"<UL>"
,@(map
(lambda (doc-pair)
(let* ([manual (car doc-pair)]
[name (cdr doc-pair)]
[manual-path (find-doc-directory manual)])
(string-append
"<LI> Download and install <A mzscheme=\""
(to-string/escape-quotes
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
(list (cons (bytes->path ,(path->bytes manual))
,name))))
(format "\">~a</A>~a"
name
(if (and manual-path
(or (file-exists? (build-path manual-path "hdindex"))
(file-exists? (build-path manual-path "keywords"))))
" (index installed)"
"")))))
uninstalled)
"</UL>")))
(list "</body></html>")))))
(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 the ~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 (bytes->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)))))))))
(define (doc.txt-manuals)
(let-values ([(collections-doc-files collection-names) (colldocs)])
(let ([name/html-pairs
(map
(lambda (collection-doc-file name)
(cons
name
(let ([path (build-path (car collection-doc-file)
(cadr collection-doc-file))])
(format "<LI> ~a"
(if (file-exists? path)
(format "<A HREF=\"/servlets/doc-anchor.ss?file=~a&name=~a&caption=Documentation for the ~a\">~a</A>"
;; escape colons and other junk
(uri-encode (path->string path))
(uri-encode name)
(uri-encode name)
name)
(format "<FONT COLOR=\"RED\">~a: specified doc.txt file (~a) not found</FONT>"
name path))))))
collections-doc-files
collection-names)])
(map cdr (sort name/html-pairs (λ (x y) (string-ci<=? (car x) (car y))))))))
;; 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)))
@ -222,90 +236,54 @@
(cons para-mark l)
(cons fst (loop (cdr l)))))]
[else (cons fst (loop (cdr l)))]))]))))
;; build-known-manuals : (listof (cons string[title] string[path])) -> (listof string)
(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)])
(cons (build-known-section section in)
(loop (cdr sections) out)))])))
;; build-known-section : sec (listof (cons string[title] string[path]))) -> string
(define (build-known-section sec names+paths)
(if (null? names+paths)
""
(string-append
"<h3>" (sec-name sec) "</h3>"
"<ul>"
(apply
string-append
(map (lambda (x)
(if (string? x)
x
(mk-link (cdr x) (car x))))
(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)))]))))
"</ul>")))
;; mk-link : string string -> string
;; mk-link : string string -> xexpr
(define (mk-link doc-path name)
(let* ([manual-name (basename doc-path)]
[index-file (get-index-file doc-path)])
(format "<LI> <A HREF=\"~a\">~a</A>~a"
(get-help-url (build-path doc-path index-file))
name
(if (and (repos-or-nightly-build?)
(file-exists? (build-path doc-path index-file)))
(string-append
"<BR>&nbsp;&nbsp;"
"<FONT SIZE=\"-1\">"
(if (is-known-doc? doc-path)
(string-append
(format
"[<A mzscheme=\"~a\">~a</a>]"
(to-string/escape-quotes
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
(list (cons (bytes->path ,(path->bytes manual-name))
,name))))
(string-constant plt:hd:refresh))
"&nbsp;")
"")
(format (string-constant plt:hd:manual-installed-date)
(date->string
(seconds->date
(file-or-directory-modify-seconds
(build-path doc-path index-file)))))
"</FONT>")
""))))
`(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
; TODO: The path->bytes is rewritten as path-&gt;bytes
; by xexpr->string (somewehere in the web-server)
; Figure out how to avoid it.
,(to-string/escape-quotes
`((dynamic-require '(lib "refresh-manuals.ss" "help") 'refresh-manuals)
(list (cons (bytes->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))))
(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
@ -315,26 +293,26 @@
(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)))])))
[(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)])
@ -346,13 +324,13 @@
(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)))
@ -364,7 +342,9 @@
(build-path "index.htm")]
[(file-exists? (build-path doc-dir "index.html"))
(build-path "index.html")]
[(tex2page-detected doc-dir) => values]
[(tex2page-detected doc-dir)
=>
(lambda (x) x)]
[else #f]))
;; tex2page-detected : string -> (union #f string)
@ -385,9 +365,10 @@
(loop (cdr contents))))])))
(provide main-manual-page)
(provide finddoc
finddoc-page-anchor)
(provide find-manuals
main-manual-page
finddoc
finddoc-page-anchor)
(provide/contract [manual-entry (string? string? xexpr? . -> . xexpr?)]
[finddoc-page (string? string? . -> . string?)]
@ -396,6 +377,4 @@
[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?))])
(provide find-manuals))
[get-index-file (path? . -> . (or/c false/c path?))]))

2
collects/help/private/search.ss
View File

@ -68,7 +68,7 @@
(set! doc-names (append
std-doc-names
(map (lambda (s) (format "the ~a" s))
(map (lambda (s) (format "the ~a collection" s))
txt-doc-names)))
(set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))

30
collects/help/private/standard-urls.ss
View File

@ -1,11 +1,11 @@
(module standard-urls mzscheme
(require "../servlets/private/util.ss"
"internal-hp.ss"
"get-help-url.ss"
(lib "uri-codec.ss" "net")
(require (lib "uri-codec.ss" "net")
(lib "dirs.ss" "setup")
(lib "contract.ss"))
(lib "contract.ss")
(lib "config.ss" "planet")
"../servlets/private/util.ss"
"internal-hp.ss"
"get-help-url.ss")
(provide home-page-url)
@ -88,6 +88,24 @@
; 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?

19
collects/help/servlets/acknowledge.ss
View File

@ -1,18 +1,19 @@
(module acknowledge mzscheme
(require (lib "acks.ss" "drscheme")
(lib "servlet.ss" "web-server")
"private/util.ss")
"private/html.ss")
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(with-errors-to-browser
(with-errors-to-browser
send/finish
(lambda ()
`(html (head (title "Acknowledgements"))
(body (a ([name "acknowledgements"] [value "acknowledgements"]))
(h1 "Acknowledgements")
(p)
,(get-general-acks)
(p)
,(get-translating-acks)))))))
(html-page
#:title "Acknowledgements"
#:bodies `((a ([name "acknowledgements"] [value "acknowledgements"]))
(h1 "Acknowledgements")
(p)
,(get-general-acks)
(p)
,(get-translating-acks)))))))

5
collects/help/servlets/doc-anchor.ss
View File

@ -5,7 +5,7 @@
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(with-errors-to-browser
(with-errors-to-browser
send/finish
(lambda ()
(let* ([bindings (request-bindings initial-request)]
@ -15,4 +15,5 @@
(read-doc (extract-binding/single 'file bindings)
(extract-binding/single 'caption bindings)
(extract-binding/single 'name bindings)
offset))))))
offset))))))

5
collects/help/servlets/doc-content.ss
View File

@ -6,7 +6,7 @@
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(with-errors-to-browser
(with-errors-to-browser
send/finish
(lambda ()
(let* ([bindings (request-bindings initial-request)]
@ -18,4 +18,5 @@
`(html (head (title "PLT Help Desk")
,hd-css
,@hd-links)
,(read-lines file caption offset)))))))
,(read-lines file caption offset)))))))

5
collects/help/servlets/doc-message.ss
View File

@ -6,11 +6,12 @@
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(with-errors-to-browser
(with-errors-to-browser
send/finish
(lambda ()
(let ([bindings (request-bindings initial-request)])
`(html (head ,hd-css ,@hd-links (title "PLT collection message"))
(body ,(format-collection-message
(extract-binding/single 'msg bindings))
(hr))))))))
(hr))))))))

506
collects/help/servlets/home.ss
View File

@ -1,63 +1,467 @@
(module home mzscheme
(require "private/util.ss"
"../private/get-help-url.ss"
(require (lib "servlet.ss" "web-server")
(lib "match.ss")
(lib "acks.ss" "drscheme")
(lib "uri-codec.ss" "net")
(lib "dirs.ss" "setup")
(lib "list.ss")
"../private/manuals.ss"
(lib "servlet.ss" "web-server"))
"private/util.ss" ; for plt-version
"private/url.ss"
"private/html.ss"
"private/split-screen.ss"
"private/platform.ss")
(define copyright-year 2007)
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define items
`(("Help Desk" "How to get help" "/servlets/howtouse.ss")
("Software" "How to run programs" "/servlets/howtoscheme.ss"
,(lambda () `("Tour" ,(get-manual-index "tour")))
("Languages" "/servlets/scheme/what.ss")
("Manuals" "/servlets/manuals.ss")
("Release" "/servlets/releaseinfo.ss")
,(lambda ()
(manual-entry "drscheme" "frequently asked questions" "FAQ")))
("Program Design" "Learning to program in Scheme" "/servlets/howtoprogram.ss"
("Teachpacks" "/servlets/teachpacks.ss")
("Why DrScheme?" "/servlets/research/why.ss"))
("External Resources" "Additional information" "/servlets/resources.ss"
("TeachScheme!" "/servlets/resources/teachscheme.ss")
("Libraries" "/servlets/resources/libext.ss")
("Mailing Lists" "/servlets/resources/maillist.ss"))))
(define (item i)
(define (item->xexpr item)
(cond [(and (pair? item) (symbol? (car item))) item]
[(procedure? item) (item->xexpr (item))]
[else `(a ([href ,(cadr item)]) ,(car item))]))
(let ([title (car i)] [subtitle (cadr i)] [url (caddr i)] [subs (cdddr i)])
`(li (b (a ([href ,url]) ,title)) ": " ,subtitle
,@(if (null? subs)
'()
`((br) nbsp nbsp nbsp nbsp nbsp nbsp
(font ([size "-2"])
,@(apply append (map (lambda (s) `(,(item->xexpr s) ", "))
subs))
"...")))
(br) (br))))
; html-subpage : xexprs -> xexpr
(define (html-subpage . xs)
(case (current-helpdesk-platform)
[(internal-browser-simple)
(apply make-simple-page/internal-browser xs)]
[(internal-browser)
(apply make-split-page/internal-browser xs)]
[else
(apply make-split-page xs)]))
(define (start initial-request)
(with-errors-to-browser
send/finish
(lambda ()
`(html
(head (title "PLT Help Desk"))
(body
(table ([cellspacing "0"] [cellpadding "0"])
(tr (td (h1 "PLT Help Desk")
(ul ,@(map item items))
(p) nbsp nbsp nbsp
(b (a ((href "/servlets/acknowledge.ss"))
(font ([color "forestgreen"]) "Acknowledgements")))
nbsp nbsp nbsp nbsp
(b (a ([mzscheme
"((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"])
(font ([color "forestgreen"]) "Send a bug report")))
(p)
(i "Version: " ,(plt-version)))))))))))
(let* ([bindings (request-bindings initial-request)]
[subpage (if (exists-binding? 'subpage bindings)
(extract-binding/single 'subpage bindings)
"home")])
; dispatch on subpage
; the dynamic ones (manuals and release) are handled are here,
; the static pages below
(match subpage
["manuals"
(html-subpage
"PLT Scheme Help Desk: Installed Manuals"
(html-top initial-request) (left-items) ""
`((h3 "NOTE")
(p "To see the list of manuals installed on " (i "your") " computer, "
" use the HelpDesk from within DrScheme. This list of manuals reflects "
"what is installed on this HelpDesk server only.")
(VERBATIM ,(find-manuals))))]
["release"
(let ()
(define (link-stuff url txt) `(li (b (a ([href ,url]) ,txt))))
(html-subpage
"PLT Scheme Help Desk: Release Info"
(html-top initial-request) (left-items) ""
`((VERBATIM
((h3 "NOTE")
(p "To see the release information for your installation, use the HelpDesk from "
"within DrScheme. "
"The following information reflects the installation on this server only.")
(h1 "Release Information")
(p)
(i "Version: " ,(plt-version))
(p)
(ul ,(link-stuff url-helpdesk-license "License")
,(link-stuff url-helpdesk-release-notes "Release Notes")
,(link-stuff url-helpdesk-known-bugs "Known Bugs")
#;(li (a ([mzscheme "((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"])
(b "Submit a bug report")))
,(link-stuff url-helpdesk-patches "Downloadable Patches"))
(p)
"The PLT software is installed on this machine at" (br)
(pre nbsp nbsp
,(let-values ([(base file dir?)
(split-path (collection-path "mzlib"))])
(path->string base))))))))]
[_
(let-values ([(right-header right-items)
(page-tag->title+items subpage)])
(cond
[(and (eq? (current-helpdesk-platform) 'internal-browser-simple)
(equal? subpage "home"))
; change the "home" page for internal HelpDesk with no menus
(html-subpage "PLT Scheme Help Desk: Home"
(html-top initial-request)
"home"
right-header (left-items))]
[else
(html-subpage "PLT Scheme Help Desk: Home"
(html-top initial-request)
(left-items)
right-header right-items)]))])))))
(define (left-items)
`(-- -- -- -- --
("Get help: "
nbsp nbsp nbsp nbsp
(b (a ((href ,url-helpdesk-help)) "Help Desk")))
-- --
("Learn to program in Scheme: "
nbsp nbsp nbsp nbsp
"Reference: "
'nbsp
(a ((href ,url-helpdesk-manuals)) "Manuals") ", "
(a ((href ,url-helpdesk-libraries)) "Libraries")
(br) nbsp nbsp nbsp nbsp
(b (a ((href ,url-helpdesk-program-design)) "Program Design: "))
'nbsp
(a ((href ,url-helpdesk-books)) "Books") ", "
(a ((href ,url-helpdesk-languages)) "Languages") ", "
(a ((href ,url-helpdesk-teachpacks)) "Teachpacks"))
-- --
("How to run programs: "
nbsp nbsp nbsp nbsp (b (a ((href ,url-helpdesk-software)) "Software: "))
'nbsp
(a ((href ,url-helpdesk-tour)) "Tour") ", "
(a ((href ,url-helpdesk-drscheme)) "DrScheme") ", "
(a ((href ,url-helpdesk-release)) "Release")
; (a ((href ,url-helpdesk-drscheme-faq)) "FAQ")) ; Moved to the DrScheme page
)
-- --
("Get involved:"
nbsp nbsp nbsp nbsp
(a ((href ,url-helpdesk-mailing-lists)) "Mailing Lists")
,@(case (current-helpdesk-platform)
((external-browser) `(", " (a ((href ,url-external-send-bug-report)) "Send a bug report")))
(else '())))
-- --
(""
" " " "
,@(case (current-helpdesk-platform)
[(internal-browser)
'((b (a ([mzscheme
"((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"])
(font ([color "forestgreen"]) "Send a bug report")))
nbsp nbsp)]
[else `()])
; DrScheme Acknowledgements
,@(case (current-helpdesk-platform)
[(internal-browser) `((b (a ((href ,url-helpdesk-acknowledge))
(font ([color "forestgreen"])"Acknowledgments"))))]
[else '()]))
-- -- -- --))
; page-tag->title+items : string -> (values string list-of-right-items)
(define (page-tag->title+items page-tag)
(match (assoc page-tag easy-pages)
[#f (page-tag->title+items "home")]
[(tag header body) (values header body)]))
; static subpages
; - In ALPHABETICAL order
(define easy-pages
`(("acknowledge" "Acknowledgements"
((p ,(get-general-acks))
(p ,(get-translating-acks))))
("books" "Books"
((h3 "HTDP - How to Design Programs")
(p (a ((href "http://www.htdp.org/"))
"'How to Design Programs - An Introduction to Programming and Computing'")
(br)
" by Matthias Felleisen, Robert Bruce Findler, Matthew Flatt, and Shriram Krishnamurthi")
(p (a ((href "http://www.ccs.neu.edu/home/matthias/htdp-plus.html")) "HTDP+")
(br)
" Supplemental Materials for 'How to Design Programs'")
(h3 "Teach Yourself Scheme in Fixnum Days")
(p (a ((href, url-helpdesk-teach-yourself))
" Teach Yourself Scheme in Fixnum Days")
(br)
"- an introduction to Scheme by Dorai Sitaram")))
("drscheme" "DrScheme"
((p "DrScheme is PLT's flagship programming environment")
(ul (li (a ((href ,url-helpdesk-tour)) (b "Tour: ") "An introduction to DrScheme"))
(li (a ((href ,url-helpdesk-interface-essentials)) "Quick-start jump into the user manual"))
(li (a ((href ,url-helpdesk-languages)) "Languages: ") "supported by DrScheme")
(li (a ((href ,url-helpdesk-drscheme-manual)) "PLT DrScheme: Programming Environment Manual")
(br) "The complete user manual")
(li (a ((href ,url-helpdesk-drscheme-faq)) "FAQ") ": DrScheme Frequently asked questions")
(li (a ((href ,url-helpdesk-why-drscheme)) "Why DrScheme?")))))
("home" "Help Desk Home"
((p "The HelpDesk is a complete source of information about PLT software, "
"including DrScheme, MzScheme and MrEd.")
(p "There are two ways to find information in the Help Desk: searching and browsing.")
(h3 "Search the Help Desk")
(p "Search for keywords, index entries or raw text in the documentation pages"
(ul (li (i "Keywords: ") "are Scheme names, such as " (b "define") " and " (b "cons")".")
(li (i "Index entries: ") "are topical phrases, such as 'lists'.")
(li (i "Raw text: ") "are fragments of text from the documentation pages. "
"Use only as a last resort."))
"The Help Desk search results are sorted according to their source.")
(h3 "Browse the Help Desk")
(ul (li "The " (b "Home") " link will take you back to this page.")
(li "The " (b "Manuals") " link displays a list of manuals and other documentation")
#;(li "The " (b "Send a bug report") " link allows you to submit a bug report to PLT."))))
("known-bugs" "Known Bugs"
((p (a ([name "bugs"] [value "Bugs"]))
"For an up-to-date list of bug reports, see the "
(a ([href "http://bugs.plt-scheme.org/query/"] [target "_top"])
"PLT bug report query page") ".")))
("languages" "Scheme Languages"
((p "DrScheme supports many dialects of Scheme. "
"The following dialects are specifically designed for teaching "
"computer science. In DrScheme's "
; TODO: (a ([href "/servlets/scheme/what.ss#lang-sel"]) "language selection menu")
(b "Language selection menu") ", "
"they are found under the heading "
(b "How to Design Programs") "."
(ul (li (b "Beginning Student") " is a pedagogical version of Scheme "
"that is tailored for beginning computer science students.")
(li (b "Beginning Student with List Abbreviations") " extends Beginning Student "
"with convenient (but potentially confusing) "
"ways to write lists, including quasiquote.")
(li (b "Intermediate Student") " adds local bindings and higher-order functions.")
(li (b "Intermediate Student with Lambda") " adds anonymous functions.")
(li (b "Advanced Student") " adds mutable state.")))
(p "The " (b "The Essentials of Programming Languages")
" language is designed for use with the MIT Press textbook with that name.")
(p "Other dialects are designed for practicing programmers. "
"The R5RS language is a standard dialect of Scheme that is defined by the "
"Revised^5 Report on the Algorithmic Language Scheme. "
"In DrScheme's language selection menu, the following languages are found under the heading PLT: ")
(ul (li (b "Textual (MzScheme)") " is a superset of R5RS Scheme. "
"In addition to the base Scheme language, PLT Scheme provides "
"exceptions, threads, objects, modules, components, regular expressions, "
"TCP support, filesystem utilities, and process control operations. "
"This language is defined in PLT MzScheme: Language Manual. ")
(li (b "Graphical (MrEd)") " includes the Textual (MzScheme) language "
"and adds a graphical toolbox, described in PLT MrEd: Graphical Toolbox Manual.")
(li (b "Pretty Big") " is a superset of the Graphical (MrEd) language, "
"and adds forms from the Pretty Big language. "
"For those forms that are in both languages, Pretty Big behaves like Graphical (MrEd)."))
(p "The " (b "module language") " supports development using PLT Scheme's module form, "
"where the module's language is explicitly declared in the code.")
(p "See the DrScheme manual for further details on the languages, especially the "
"teaching languages.")
(p "DrScheme's set of languages can be extended, so the above list mentions only "
"the languages installed by default. "
"Documentation for all languages is available through the manuals page.")))
("libraries" "Libraries"
((h3 "Built-in Libraries")
(p "PLT Scheme has a lot of libraries. The core libraries are described in "
(a ((href ,url-helpdesk-mzlib)) "PLT MzLib: Libraries Manual"))
(p "See the " (a ((href ,url-helpdesk-manuals)) "Manuals") " page for more.")
(h3 "User / PLaneT Libraries")
(p (a ((href ,url-external-planet)) "PLaneT") " is the repository for user contributed libraries. "
"Join the PLaneT announcement mailing list to get notified on new PLaneT packages.")))
("license" "License"
((a ([name "lic"] [value "License"]))
(b "PLT Software") (br)
(b ,(format "Copyright (c) ~a PLT Scheme Inc." copyright-year))
(p "PLT software is distributed under the GNU Library General Public "
" License (LGPL). This means you can link PLT software (such as "
"MzScheme or MrEd) into proprietary applications, provided you follow "
"the specific rules stated in the LGPL. You can also modify PLT "
"software; if you distribute a modified version, you must distribute it "
"under the terms of the LGPL, which in particular means that you must "
"release the source code for the modified software. See "
(a ([href ,(format "/servlets/doc-anchor.ss?~a&file=~a"
"name=COPYING.LIB&caption=Copying PLT software"
(uri-encode
(path->string
(simplify-path (build-path (find-doc-dir)
"release-notes"
"COPYING.LIB")))))])
"COPYING.LIB")
" for more information.")
(p "PLT software includes or extends the following copyrighted material:"
,@(let ()
(define (make-item ss) `(ul (li ,@(map (lambda (s) `(div ,s (br))) ss))))
(map
make-item
`(("DrScheme"
,(format "Copyright (c) 1995-~a PLT" copyright-year)
,(format "Copyright (c) 2004-~a PLT Scheme Inc." copyright-year)
"All rights reserved.")
("MrEd"
,(format "Copyright (c) 1995-~a PLT" copyright-year)
,(format "Copyright (c) 2004-~a PLT Scheme Inc." copyright-year)
"All rights reserved.")
("MzScheme"
,(format "Copyright (c) 1995-~a PLT" copyright-year)
,(format "Copyright (c) 2004-~a PLT Scheme Inc." copyright-year)
"All rights reserved.")
("libscheme"
"Copyright (c) 1994 Brent Benson"
"All rights reserved.")
("wxWindows"
,(string-append "Copyright (c) 1994 Artificial Intelligence Applications Institute, "
"The University of Edinburgh")
"All rights reserved.")
("wxWindows Xt"
,(string-append "Copyright (c) 1994 Artificial Intelligence Applications Institute, "
"The University of Edinburgh")
"Copyright (c) 1995 GNU (Markus Holzem)"
"All rights reserved.")
("Conservative garbage collector"
"Copyright (c) 1988, 1989 Hans-J. Boehm, Alan J. Demers"
"Copyright (c) 1991-1996 Xerox Corporation"
"Copyright (c) 1996-1999 Silicon Graphics"
"Copyright (c) 1999-2001 by Hewlett-Packard Company"
"All rights reserved.")
("Collector C++ extension by Jesse Hull and John Ellis"
"Copyright (c) 1994 Xerox Corporation"
"All rights reserved.")
("The A List"
"Copyright (c) 1997-2000 Kyle Hammond."
"All rights reserved.")
("Independent JPEG Group library"
"Copyright (c) 1991-1998 Thomas G. Lane."
"All rights reserved.")
("libpng"
"Copyright (c) 2000-2002 Glenn Randers-Pehrson"
"All rights reserved.")
("zlib"
"Copyright (c) 1995-2002 Jean-loup Gailly and Mark Adler"
"All rights reserved.")
("GNU MP Library"
"Copyright (c) 1992, 1993, 1994, 1996 by Free Software Foundation, Inc.")
("GNU lightning"
"Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.")
("GNU Classpath"
"GNU Public License with special exception")))))))
("mailing-lists" "Mailing Lists"
((p "There are two mailing lists: the discussion list and the announcements only list.")
(h3 "Archives")
(p "The lists are archived:"
(ul (li (a ((href ,url-external-discussion-list-archive)) "Discussions")
" - " (a ((href ,url-external-discussion-list-archive-old)) "(old archive)"))
(li (a ((href ,url-external-announcement-list-archive)) "Announcements only"))))
(h3 "Subscribing")
(p "Visit the " (a ((href ,url-external-mailing-list-subscription))
"subscription page") " to join the mailing lists.")))
("patches" "Downloadable Patches"
((p (a ([name "patches"] [value "Downloadable patches"]))
"The following Web page may contain downloadable patches to fix "
"serious bugs in version " ,(version) " of the PLT software:")
(p nbsp nbsp
,(let ([url (format "http://download.plt-scheme.org/patches/~a/"
(version))])
`(a ([href ,url] [target "_top"]) ,url)))))
("program-design" "Program Design"
((h3 "For Students")
(p "The textbook " (a ((href "http://www.htdp.org")) "How to Design Programs")
" provides an introduction to programming using the DrScheme environment. "
"The Help Desk provides the following interactve support for the text book: "
(a ((href ,url-helpdesk-teachpacks)) "Teachpack documentation"))
(h3 "For Experienced Programmers")
(p (a ((href ,url-helpdesk-teach-yourself)) "Teach Yourself Scheme in a Fixnum Days")
": For programmers with lots of experience in other languages")
(h3 "For Teachers and Researchers")
(p (a ((href ,url-helpdesk-why-drscheme)) "PLT's vision"))))
("release-notes" (h1 "Release Notes for PLT Scheme version " ,(version))
((a ([name "relnotes"] [VALUE "Release notes"]))
(p "Detailed release notes:"
(ul
,@(let ()
(define (make-release-notes-entry s)
(match s
[(label dir filename)
(let ([file (build-path (find-doc-dir) "release-notes" dir filename)])
(if (file-exists? file)
`(li (a ([href ,(format
"/servlets/doc-anchor.ss?file=~a&name=~a&caption=~a"
(uri-encode (path->string file))
filename
label)])
,label))
#f))]))
(filter
values ; delete #f entries
(map make-release-notes-entry
'(("DrScheme release notes" "drscheme" "HISTORY")
("Teachpack release notes" "teachpack" "HISTORY")
("MzScheme version 300 notes" "mzscheme" "MzScheme_300.txt")
("MzScheme release notes" "mzscheme" "HISTORY")
("MrEd release notes" "mred" "HISTORY")
("Stepper release notes" "stepper" "HISTORY")
("MrFlow release notes" "mrflow" "HISTORY")))))))))
("software" "Software"
((ul (li (a ((href ,url-helpdesk-drscheme)) "DrScheme") ": The programming environment")
(li (a ((href ,url-helpdesk-languages)) "Languages") ": The family of languages "
"supported by PLT Software")
; (li (a ((href ,url-helpdesk-documentation)) "Documentation")
; ": Organization and manuals")
; (li (a ((href ,url-helpdesk-hints)) "Hints")
; ": How to do things in Scheme")
)))
("teachpacks" "Teachpacks"
((ul (li (a ((href ,url-helpdesk-teachpacks-for-htdp))
"Teachpacks for 'How to Design Programs'"))
(li (a ((href ,url-helpdesk-teachpacks-for-htdc))
"Teachpacks for 'How to Design Classes'")))))
("teachscheme" "Teach Scheme"
((h2 "TeachScheme! Workshops")
(p (a ([name "workshops"] [value "TeachScheme! workshops"]))
"TeachScheme! is a free summer workshop for high school teachers. "
"Its goal is to bridge the gulf between high school and "
"college-level computing curricula. In the workshop, programming "
"is taught as an algebraic problem-solving process, and computing "
"is the natural generalization of grade-school level calculating." )
(p "Students who learn to design programs properly learn to "
"analyze a problem statement; express its essence, abstractly "
"and with examples; formulate statements and comments in a "
"precise language; evaluate and revise these activities in "
"light of checks and tests; and pay attention to details. "
"As a result, all students benefit, those who wish to study computing "
"as well as those who just wish to explore the subject.")
(p "For more information, see the "
(a ([href "http://www.teach-scheme.org/Workshops/"]
[TARGET "_top"])
"TeachScheme! Workshops page") ".")))
("tour" "Tour of DrScheme"
((p "Take a " (a ((href ,url-external-tour-of-drscheme)) "Tour of DrScheme")
" and discover the wealth of features of the interactive, "
"integrated programming environment.")))
("why-drscheme" "Why DrScheme?"
((p "Teaching introductory computing courses with Scheme, or any other "
"functional programming language, facilitates many conceptual tasks "
"and greatly enhances the appeal of computer science. Specifically, "
"students can implement many interesting programs with just a small "
"subset of the language. The execution "
"of a functional program can be explained with simple reduction "
"rules that students mostly know from "
"secondary school. Interactive implementations allow for quick "
"feedback to the programmers andmake the "
"development of small functions a pleasant experience.")
(p "Unfortunately, the poor quality of the available environments "
"for functional languages negates these advantages. Typical "
"implementations accept too many definitions, that is, definitions "
"that are syntactically well-formed in the sense of the full "
"language but meaningless for beginners. The results are inexplicable "
"behavior, incomprehensible run-time errors, or confusing type "
"error messages. The imperative nature of "
"read-eval-print loops often introduces subtle bugs into otherwise "
"perfect program developments. Scheme, in "
"particular, suffers from an adherence to Lisp's output traditions, "
"which often produces confusing effects. "
"In many cases students, especially those familiar with commercial C++ "
"environments, mistake these problems "
"for problems with the functional approach and reject the approach itself. ")
(p "To overcome this obstacle, we have developed a new programming "
"environment for Scheme. It fully integrates a "
"(graphics-enriched) editor, a multi-lingual parser that can process a "
"hierarchy of syntactically restrictive "
"variants of Scheme, a functional read-eval-print loop, and an "
"algebraically sensible printer. The environment "
"catches the typical syntactic mistakes of beginners and pinpoints "
"the exact source location of run-time "
"exceptions. The new programming environment also provides an "
"algebraic stepper and a static debugger. The "
"former reduces Scheme programs, including programs with assignment "
"and control effects, to values (and effects). "
"The static debugger infers what set of values an expression may "
"produce and how values flow from expressions "
"into variables. It exposes potential safety violations and, upon "
"demand from the programmer, explains its "
"reasoning by drawing value flowgraphs over the program text. "
"Preliminary experience with the environment shows "
"that students find it helpful and that they greatly prefer it to "
"shell-based or Emacs-based systems.")
(p "A paper that discusses DrScheme in more detail is available in the paper: "
(a ((href "http://www.ccs.neu.edu/scheme/pubs/#jfp01-fcffksf"))
"DrScheme: A Programming Environment for Scheme."))))
)))

54
collects/help/servlets/howtoscheme.ss
View File

@ -1,38 +1,28 @@
(module howtoscheme mzscheme
(require "../private/manuals.ss"
"private/headelts.ss"
(lib "servlet.ss" "web-server"))
(module howtodrscheme mzscheme
(require (lib "servlet.ss" "web-server")
"../private/manuals.ss"
"private/html.ss")
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(with-errors-to-browser
(with-errors-to-browser
send/finish
(lambda ()
`(html
(head ,hd-css ,@hd-links (title "Software"))
(body
(h1 "Software")
(ul (li (b (a ([href "howtodrscheme.ss"]) "DrScheme"))
": The programming environment")
(li (b (a ([href "/servlets/scheme/what.ss"]) "Languages"))
": The family of languages supported by PLT Software")
(li (b (a ([href "/servlets/scheme/how.ss"])
"Software & Components"))
": The full suite of PLT tools "
(br) nbsp nbsp nbsp nbsp
(font ([size "-2"])
(a ([href "/servlets/scheme/how.ss#installed-components"])
"Installed Components")
", ..."))
(li (b (a ([href "/servlets/scheme/doc.ss"]) "Documentation"))
": Organization and manuals "
(br) nbsp nbsp nbsp nbsp
(font ([size "-2"])
(a ([href "/servlets/manuals.ss"]) "Manuals") ", ...") )
(li (b (a ([href "scheme/misc.ss"]) "Hints"))
": How to do things in Scheme " )
(li (b ,(manual-entry "drscheme" "frequently asked questions" "FAQ"))
": Frequently asked questions")
(li (b (a ([href "releaseinfo.ss"]) "Release Information"))
": License, notes, and known bugs"))))))))
(html-page
#:title "DrScheme"
#:bodies `((h1 "DrScheme")
"DrScheme is PLT's flagship programming environment. "
"See " (a ((href "/servlets/scheme/how.ss")) "Software & Components")
" for a guide to the full suite of PLT tools."
(ul (li (b (a ([href ,(get-manual-index "tour")])) "Tour")
": An introduction to DrScheme")
(li (b ,(manual-entry "drscheme"
"graphical interface"
"Interface Essentials"))
": Quick-start jump into the user manual")
(li (b (a ([href "/servlets/scheme/what.ss"])
"Languages"))
": Languages supported by DrScheme")
(li (b ,(main-manual-page "drscheme"))
": The complete user manual"))))))))

18
collects/help/servlets/manual-section.ss
View File

@ -1,7 +1,7 @@
(module manual-section mzscheme
(require "../private/manuals.ss"
"private/headelts.ss"
(lib "servlet.ss" "web-server"))
(require (lib "servlet.ss" "web-server")
"../private/manuals.ss"
"private/html.ss")
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
@ -19,15 +19,15 @@
[page (with-handlers
([void (lambda _
(send/finish
`(html
(head ,hd-css ,@hd-links
(title "Can't find manual section"))
(body
"Error looking up PLT manual section"
(html-page
#:title "Can't find manual section"
#:bodies
`("Error looking up PLT manual section"
(p)
"Requested manual: "
,manual (br)
"Requested section: "
,section))))])
(finddoc-page-anchor manual section))])
(send/finish (redirect-to page)))))))
(send/finish (redirect-to page)))))))

52
collects/help/servlets/missing-manual.ss
View File

@ -1,12 +1,12 @@
(module missing-manual mzscheme
(require (lib "servlet.ss" "web-server")
"private/headelts.ss"
"../private/standard-urls.ss"
"private/util.ss"
"../private/standard-urls.ss")
"private/html.ss")
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(with-errors-to-browser
send/finish
@ -15,29 +15,29 @@
(no-manual (extract-binding/single 'manual bindings)
(extract-binding/single 'name bindings)
(extract-binding/single 'link bindings))))))
(define (no-manual manual label link)
(let* ([html-url (make-docs-html-url manual)]
[plt-url (make-docs-plt-url manual)])
`(html
(head ,hd-css ,@hd-links (title "Missing PLT manual"))
(body ([bgcolor "white"])
,(with-color "red" `(h1 "Documentation missing"))
(p)
"You tried to access documentation for "
,(with-color "blue" `(b ,label)) ". "
"The documentation is not installed on this machine, probably"
" because it is not part of the standard DrScheme distribution."
(p)
(h2 "Install Locally")
(a ((href ,plt-url)) "Download and/or install")
" the documentation."
(br)
"After installing, "
(a ((href ,link)) "continue")
" to the originally requested page."
(br) nbsp (br)
(h2 "Read Online")
"Read the documentation on "
(a ((href ,html-url)) "PLT's servers")
".")))))
(html-page
#:title "Missing PLT manual"
#:bodies
`(,(with-color "red" `(h1 "Documentation missing"))
(p)
"You tried to access documentation for "
,(with-color "blue" `(b ,label)) ". "
"The documentation is not installed on this machine, probably"
" because it is not part of the standard DrScheme distribution."
(p)
(h2 "Install Locally")
(a ((href ,plt-url)) "Download and/or install")
" the documentation."
(br)
"After installing, "
(a ((href ,link)) "continue")
" to the originally requested page."
(br) nbsp (br)
(h2 "Read Online")
"Read the documentation on "
(a ((href ,html-url)) "PLT's servers")
".")))))

6
collects/help/servlets/private/helpdesk.css Normal file
View File

@ -0,0 +1,6 @@
.sansa { font-family: Arial, Helvetica, sans-serif; }
.sansa a:link { color: #3a652b; text-decoration: none; background-color: transparent; }
.sansa a:visited { color: #3a652b; text-decoration: none; background-color: transparent; }
.sansa a:active { color: #3a652b; text-decoration: none; background-color: #97d881; }
.sansa a:hover { color: #3a652b; text-decoration: none; background-color: #97d881; }
body { background-color: white; font-family: Arial, Helvetica, sans-serif; }

187
collects/help/servlets/private/html.ss Normal file
View File

@ -0,0 +1,187 @@
(module html mzscheme
(provide (all-defined))
(require (lib "servlets/private/search-util.ss" "help")
(lib "servlet.ss" "web-server")
(lib "etc.ss")
(lib "kw.ss")
(lib "port.ss")
"url.ss")
;;;
;;; STYLESHEET
;;;
; css : -> string
; fetch stylesheet from disk
; (convenient during development)
(define (css)
(define (port->string port)
(let ([os (open-output-string)])
(copy-port port os)
(get-output-string os)))
(call-with-input-file
(build-path (this-expression-source-directory)
"helpdesk.css")
port->string))
;;;
;;; GENERATE XML FOR THE ENTIRE PAGE
;;;
; html-page : xexpr (list xml) (list xml) -> xexpr
(define/kw (html-page #:key title (top '()) (bodies '()) body)
(let ([bodies (if body (append bodies (list body)) bodies)])
`(html
(meta ((http-equiv "Content-Type") (content "text/html;charset=UTF-8")))
(meta ((name "generator") (content "PLT Scheme")))
; TODO: Ask Eli what exactly to put here in the online version
;(script ((src "http://www.google-analytics.com/urchin.js") (type "text/javascript")))
;(script ((type "text/javascript")) "_uacct=\"UA-808258-1\";_udn=\"plt-scheme.org\";urchinTracker();")
(head (title ,title)
(style ((type "text/css")) "\n"
,(css))
; TODO: Check the icons work in online version
(link ([rel "icon"] [href "/help/servlets/plticon.ico"] [type "image/ico"]))
(link ([rel "shortcut icon"] [href "/help/servlets/plticon.ico"])))
(body
,@top
,@bodies))))
; html-select : string (list string) natural -> xexpr
(define (html-select name descriptions selected-index)
`(select ((name ,name))
,@(let loop ([i 0] [ds descriptions] [xexprs '()])
(cond
[(null? ds) (reverse! xexprs)]
[(= i selected-index) (loop (+ i 1) (cdr ds)
(cons (car ds)
(cons `(option ((selected "selected")))
xexprs)))]
[else (loop (+ i 1) (cdr ds)
(cons (car ds)
(cons `(option)
xexprs)))]))))
;;;
;;; THE TOP SEARCH BAR
;;; (online version online)
; html-top : requrest -> (list xml)
(define (html-top request)
(let* ([bindings (request-bindings request)]
[search-string (get-binding bindings 'search-string "")]
[search-type (get-binding bindings 'search-type search-type-default)]
[match-type (get-binding bindings 'match-type match-type-default)])
`((div ((style "border: 1px solid black; padding: 3px; background-color: #74ca56; "))
(table ((width "98%"))
(tr (td ((align "right"))
(img ((class "image")
(src "http://www.plt-scheme.org/plt-green.jpg")
(width "133") (height "128") (alt "[icon]"))))
(td ((align "center"))
(form ((method "GET") (action ,url-helpdesk-results))
(table (tr (td ((align "center") (class "sansa"))
"Search the Help Desk for documentation on: " ))
(tr (td (input ((name "search-string") (type "text") (size "70")
(value ,search-string))))
(td 'nbsp 'nbsp (button "Search")))
(tr (td ((align "center"))
,(html-select "search-type"
search-type-descriptions
(search-type->index search-type))
'nbsp 'nbsp 'nbsp 'nbsp
,(html-select "match-type"
match-type-descriptions
(match-type->index match-type)))))))
(td 'nbsp) (td 'nbsp) (td 'nbsp)
(td (table (tr (td ((align "center"))
(a ((href ,url-helpdesk-home) (class "sansa")) "HOME")))
(tr (td ((align "center"))
(a ((href ,url-helpdesk-manuals) (class "sansa")) "MANUALS")))))
)))
(p " "))))
;;;
;;; BINDINGS
;;;
(define (get-binding bindings name default-value)
(if (exists-binding? name bindings)
(extract-binding/single name bindings)
default-value))
(define (delete-binding id bindings)
(cond
[(null? bindings)
'()]
[(equal? (binding-id (car bindings)) id)
(cdr bindings)]
[else
(cons (car bindings)
(delete-binding id (cdr bindings)))]))
(define (delete-bindings ids bindings)
(cond [(null? ids) bindings]
[else (delete-bindings (cdr ids)
(delete-binding (car ids)
bindings))]))
(define (display-binding binding)
; for debugging
(display "binding: ")
(display (binding-id binding))
(display "=")
(write (binding:form-value binding))
(newline))
;;;
;;; SEARCH DESCRIPTIONS AND SHORT NAMES
;;;
(define (search-type-description i)
(cadr (list-ref search-types i)))
(define (match-type-description i)
(cadr (list-ref match-types i)))
(define reversed-search-types
(map reverse search-types))
(define reversed-match-types
(map reverse match-types))
(define (search-type-description->search-type desc)
(cond [(assoc desc reversed-search-types) => cadr]
[else search-type-default]))
(define (match-type-description->match-type desc)
(cond [(assoc desc reversed-match-types) => cadr]
[else match-type-default]))
(define search-type->index
(let* ([types (map car search-types)]
[len (length types)])
(lambda (t)
(cond
[(member t types)
=> (lambda (tail) (- len (length tail)))]
[else -1]))))
(define match-type->index
(let* ([types (map car match-types)]
[len (length types)])
(lambda (t)
(cond
[(member t types)
=> (lambda (tail) (- len (length tail)))]
[else -1]))))
(define search-type-descriptions
(map cadr search-types))
(define match-type-descriptions
(map cadr match-types))
)

11
collects/help/servlets/private/platform.ss Normal file
View File

@ -0,0 +1,11 @@
(module platform mzscheme
(provide current-helpdesk-platform)
; internal browser or external browser?
; (used to produce simpler html for the internal browser)
(define current-helpdesk-platform
(make-parameter
'internal-browser-simple ; main page only
; 'internal-browser ; menu + main page
; 'external-browser
)))

11
collects/help/servlets/private/read-doc.ss
View File

@ -3,7 +3,7 @@
(lib "getinfo.ss" "setup")
"util.ss"
"read-lines.ss"
"headelts.ss")
"html.ss")
(provide read-doc)
;; extracts help desk message
@ -15,12 +15,13 @@
(define (build-page file caption coll offset)
(let ([msg (get-message coll)])
`(html (head (title "PLT Help Desk") ,hd-css)
,(if msg
`(body ,(format-collection-message msg)
(html-page
#:title "PLT Help Desk"
#:bodies (if msg
`(,(format-collection-message msg)
(hr)
,(read-lines file caption offset))
`(body ,(read-lines file caption offset))))))
`(,(read-lines file caption offset))))))
(define read-doc
(opt-lambda (file caption coll [offset #f])

125
collects/help/servlets/private/split-screen.ss Normal file
View File

@ -0,0 +1,125 @@
(module split-screen mzscheme
(require (lib "match.ss")
(only (lib "misc.ss" "swindle") mappend)
"html.ss"
"url.ss"
"platform.ss")
; These items are common to all split screens
(define left-header-items
`((VERBATIM (big (big (big (b (a ((href ,url-helpdesk-home)) "PLT Scheme Help Desk"))))))))
(define left-footer-items
(case (current-helpdesk-platform)
[(internal-browser)
'(nbsp)]
[else
'(nbsp
(VERBATIM (small (small (a ((href "http://www.plt-scheme.org/map.html")) "Site Map"))))
(VERBATIM (hr ((noshade "1") (size "2") (color "#3a652b"))))
(VERBATIM (nobr
(small ((class "sansa"))
(a ((href "http://www.plt-scheme.org/")) "PLT")
nbsp "|" nbsp
(a ((href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme")
nbsp "|" nbsp
(a ((href "http://www.teach-scheme.org/")) "TeachScheme!")
nbsp "|" nbsp
(a ((href "http://www.htdp.org/")) "HtDP") nbsp
"|" nbsp
(a ((href "http://planet.plt-scheme.org/")) "PLaneT")
nbsp)))
; Google Search for PLT Documentation
#;(VERBATIM (div ((align "center"))
(div ((style "display: inline; margin: 0; white-space: nowrap;"))
; The Google "Search Documentation" field and button
(form ((id "searchbox_010927490648632664335:4yu6uuqr9ia")
(action "http://www.plt-scheme.org/search/")
(style "display: inline; margin: 0;"))
(input ((type "hidden") (name "cx") (value "010927490648632664335:4yu6uuqr9ia")))
(input ((type "text") (name "q") (size "16") (style "font-size: 75%;")))
(input ((type "hidden") (name "hq") (value "more:plt")))
(input ((type "hidden") (name "cxq") (value "more:docs")))
(input ((type "submit") (name "sa") (value "Search Documentation")
(style "font-size: 75%;")))
(input ((type "hidden") (name "cof") (value "FORID:9")))))
nbsp)))]))
; the internal browser makes a "split" screen by having the left items at the top,
; and the right items at the bottom
(define (make-split-page/internal-browser title top-items left-items right-header right-items)
(html-page
#:title title
#:body `(div ,(html-left-items (append #;left-header-items
left-items left-footer-items))
(hr)
,@(html-right-items right-items))))
(define (make-simple-page/internal-browser title top-items left-items right-header right-items)
(html-page
#:title title
#:body (if (equal? left-items "home")
`(div ,(html-left-items right-items))
`(div ,@(html-right-items right-items)))))
; an external is capable of displaying a proper split screen
(define (make-split-page title top-items left-items right-header right-items)
(html-page
#:title title
#:bodies `(,@top-items ,(make-split-screen left-items right-header right-items))))
(define (make-split-screen left-items right-header right-items)
`(table ((height "80%") (width "100%") (align "center") (border "0") (cellspacing "0") (cellpadding "30"))
(tr ((valign "top"))
(td ((height "80%") (width "50%") (align "center") (valign "top") (bgcolor "#74ca56"))
; LEFT TABLE
(table ((align "center") (class "sansa") (border "0") (cellpadding "0") (cellspacing "4"))
#;(tr (td ((align "center"))
(img ((src "http://www.plt-scheme.org/plt-green.jpg")
(width "133") (height "128") (alt "[icon]")))))
,(html-left-items (append left-header-items left-items left-footer-items)))
(td ((height "100%") (width "50%") (align "left") (valign "top"))
; RIGHT TABLE
(table ((width "80%") (class "sansa") (align "center") (border "0")
(cellpadding "0") (cellspacing "0"))
(tr (td (h1 ,right-header)))
;(tr (td (small (small nbsp))))
(tr (td (table ((border "0") (cellpadding "3") (cellspacing "0") (width "100%"))
,@(html-right-items right-items))))))))))
;;;
;;; ITEM FORMATTING
;;; (ad hoc markup inherited)
(define (html-left-items items)
`(tr (td (table ,@(mappend html-left-item items)))))
(define (html-left-item item)
(match item
['UP (list '(font ((size "-2")) nbsp))]
['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
[('VERBATIM sxml) (list `(tr (td ((align "center")) ,sxml)))]
[(header) (list `(tr (td #;((colspan "2")) ,header)))]
[(header body ...) (list `(tr (td #;((colspan "2")) ,header))
`(tr (td ,@body)))]
[other (list other)]))
(define (html-right-items items)
(mappend html-right-item items))
(define (html-right-item item)
(match item
['-- (list '(tr ((height "4")) (td ((colspan "2")))))]
[('VERBATIM item) item]
[(body ...) (list body)]))
(provide make-split-screen
make-split-page
make-split-page/internal-browser
make-simple-page/internal-browser)
)

0
collects/help/servlets/private/top-search-bar.ss Normal file
View File

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

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

53
collects/help/servlets/resources.ss
View File

@ -1,6 +1,6 @@
(module resources mzscheme
(require "private/headelts.ss"
(lib "servlet.ss" "web-server"))
(require (lib "servlet.ss" "web-server")
"private/html.ss")
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
@ -8,27 +8,28 @@
(with-errors-to-browser
send/finish
(lambda ()
`(html
(head ,hd-css ,@hd-links (title "External Resources"))
(body
(h1 "External Resources")
(p)
"DrScheme is created by "
(a ([href "http://www.plt-scheme.org/"] [target "_top"]) "PLT")
" based at Northeastern University, the University of Utah,"
" Brown University, and the University of Chicago."
" Here are some links related to our activities."
(p)
(ul (li (b (a ([href "resources/teachscheme.ss"])
"TeachScheme! Workshops"))
": Free summer program")
(li (b (a ([href "resources/libext.ss"]) "Libraries"))
": From PLT and contributors")
(li (b (a ([href "resources/maillist.ss"]) "Mailing Lists"))
": How to subscribe"))
(p)
"Also, the Schemers.org Web site provides links for "
"many Scheme resources, including books, implementations, "
"and libraries: "
(a ([href "http://www.schemers.org/"] [target "_top"])
"http://www.schemers.org/") "."))))))
(html-page
#:title "External Resources"
#:bodies
`((h1 "External Resources")
(p)
"DrScheme is created by "
(a ([href "http://www.plt-scheme.org/"] [target "_top"]) "PLT")
" based at Northeastern University, the University of Utah,"
" Brown University, and the University of Chicago."
" Here are some links related to our activities."
(p)
(ul (li (b (a ([href "resources/teachscheme.ss"])
"TeachScheme! Workshops"))
": Free summer program")
(li (b (a ([href "resources/libext.ss"]) "Libraries"))
": From PLT and contributors")
(li (b (a ([href "resources/maillist.ss"]) "Mailing Lists"))
": How to subscribe"))
(p)
"Also, the Schemers.org Web site provides links for "
"many Scheme resources, including books, implementations, "
"and libraries: "
(a ([href "http://www.schemers.org/"] [target "_top"])
"http://www.schemers.org/") "."))))))

69
collects/help/servlets/results.ss
View File

@ -9,30 +9,62 @@ is stored in a module top-level and that's namespace-specific.
(module results mzscheme
(require (lib "file.ss")
(lib "list.ss")
(lib "string.ss")
(lib "servlet.ss" "web-server")
(lib "uri-codec.ss" "net")
(lib "dirs.ss" "setup")
"../private/internal-hp.ss"
"../private/path.ss"
"../private/docpos.ss"
"../private/search.ss"
"../private/manuals.ss"
"../private/get-help-url.ss"
(lib "string-constant.ss" "string-constants")
"private/util.ss"
"private/search-util.ss"
"private/headelts.ss")
"private/html.ss"
"private/platform.ss")
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
; adjust-request : request -> request
; The bindings received by the online and the internal helpdesk
; for the search and match type are different.
; The online version contains user readable descriptions for search-type
; and match-type. This function changes them to use the short versions
; as the internal HelpDesk does.
(define (adjust-request request)
(case (current-helpdesk-platform)
[(internal-browser) request]
[(internal-browser-simple) request]
[else
(let* ([bindings (request-bindings request)]
[search-type (search-type-description->search-type
(get-binding bindings 'search-type search-type-default))]
[match-type (match-type-description->match-type
(get-binding bindings 'match-type match-type-default))]
[bindings (append (list (make-binding:form #"search-type" (string->bytes/utf-8 search-type))
(make-binding:form #"match-type" (string->bytes/utf-8 match-type)))
(delete-bindings (list #"search-type" #"match-type")
(request-bindings/raw request)))]
[request (make-request (request-method request)
(request-uri request)
(request-headers/raw request)
bindings
(request-post-data/raw request)
(request-host-ip request)
(request-host-port request)
(request-client-ip request))])
request)]))
(define (start initial-request)
(with-errors-to-browser
(with-errors-to-browser
send/finish
(lambda ()
(let ()
(let* ([request (adjust-request initial-request)]
[html-for-top (case (current-helpdesk-platform)
[(internal-browser) '()]
[(internal-browser-simple) '()]
[else (html-top request)])])
;; doc subcollection name -> boolean
(define (search-type->search-level st)
(let loop ([n 0] [lst (map car search-types)])
@ -196,10 +228,11 @@ is stored in a module top-level and that's namespace-specific.
(define (make-results-page search-string lang-name items regexp? exact?)
(let-values ([(string-finds finds)
(build-string-finds/finds search-string regexp? exact?)])
`(html
(head ,hd-css ,@hd-links (title "PLT Help Desk search results"))
(body
(h1 "Search Results")
(html-page
#:title "PLT Help Desk search results"
#:top html-for-top
#:bodies
`((h1 "Search Results")
(h2
,@(if lang-name
(list "Language: " (with-color "firebrick" lang-name) '(br))
@ -246,8 +279,11 @@ is stored in a module top-level and that's namespace-specific.
html))
(define empty-search-page
`(html (head (title "Empty search string in PLT Help Desk"))
(body (h2 "Empty search string"))))
; TODO: Improve UI: Feedback possibility
(html-page
#:title "Empty search string in PLT Help Desk"
#:top html-for-top
#:body '(h2 "Empty search string")))
(define (lucky-search? bindings)
(with-handlers ([exn:fail? (lambda _ #f)])
@ -265,7 +301,7 @@ is stored in a module top-level and that's namespace-specific.
(map car (find-doc-names))))
(map car (find-doc-names))))
(let* ([bindings (request-bindings initial-request)]
(let* ([bindings (request-bindings request)]
[maybe-get (lambda (sym)
(with-handlers ([exn:fail?
(lambda (_) #f)])
@ -274,8 +310,9 @@ is stored in a module top-level and that's namespace-specific.
(cond
[flush
(doc-collections-changed)
`(html (head (title "Flush"))
(body (h2 "Flushed documentation cache")))]
(html-page #:title "flush"
#:top (html-top initial-request)
#:body '(h2 "Flushed documentation cache"))]
[else
(let ([search-string (maybe-get 'search-string)]
[search-type (maybe-get 'search-type)]
@ -294,3 +331,5 @@ is stored in a module top-level and that's namespace-specific.
[(equal? doc.txt "false") #f]
[else #t])
lang-name)))])))))))

124
collects/help/servlets/static.ss Normal file
View File

@ -0,0 +1,124 @@
; Serve static documentation.
; A search bar is added on top of the screen, when an external browser is used.
; (which is why we don't let the web-server serve the documentation directly)
(module static mzscheme
(require (lib "private/mime-types.ss" "web-server")
(lib "servlet.ss" "web-server")
(lib "xml.ss" "xml")
(lib "match.ss")
(lib "url.ss" "net")
(lib "dirs.ss" "setup")
(lib "port.ss")
"../private/standard-urls.ss"
"../private/docpos.ss"
"private/platform.ss"
"private/html.ss")
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
;;;
;;; PORT UTILS
;;;
(define (port->string port)
(let ([os (open-output-string)])
(copy-port port os)
(get-output-string os)))
(define (file->string path)
(call-with-input-file path
port->string))
(define (port->bytes port)
(let ([ob (open-output-bytes)])
(copy-port port ob)
(get-output-bytes ob)))
(define (file->bytes path)
(call-with-input-file path
port->bytes))
;;;
;;; MIME
;;;
; get-mime-type : path -> string
(define get-mime-type
(;make-get-mime-type
make-path->mime-type
(build-path (find-collects-dir)
"web-server" "default-web-root" "mime.types")))
(define (text-mime-type? file-path)
(regexp-match #rx"^text"
(get-mime-type file-path)))
;;;
;;; URL
;;;
; file-parts->file : string (list string) -> string
; (list "foo" "bar" "baz") => "foo/bar/baz"
(define (file-parts->file manual fs)
(apply string-append
(let loop ([fs (cons manual fs)])
(cond
[(null? fs) (list "")]
[(null? (cdr fs)) (list (car fs))]
[else (cons (string-append (car fs) "/")
(loop (cdr fs)))]))))
;;;
;;; TITLES
;;;
(define (short->manual-title s)
(match (assoc (string->path s) known-docs)
[#f "Documentation"]
[(path . long) long]))
(define (start request)
(with-errors-to-browser
send/finish
(lambda ()
(let* ([bindings (request-bindings request)]
[file (get-binding bindings 'file "no file")]
[host (get-binding bindings 'host "no host")]
[url (request-uri request)])
(let-values
([(file-path host manual)
(match (map path/param-path (url-path url))
[("servlets" "static.ss" host manual . file-parts)
(values (host+file->path host (file-parts->file manual file-parts))
host
manual)])])
(cond
[(not file-path)
(list #"text/html"
"<html><head><title>Not found</title></head><body>File not found.</body></html>")]
[(and (file-exists? file-path)
(text-mime-type? file-path))
(list (get-mime-type file-path)
(string-append (xexpr->string
(html-page
#:title (short->manual-title manual)
#:top (case (current-helpdesk-platform)
[(internal-browser) '()]
[(internal-browser-simple) '()]
[else (html-top request)])
#:body " "))
(file->string file-path)))]
[(file-exists? file-path)
(list (get-mime-type file-path)
(file->bytes file-path))]
[else
(list #"text/html"
(format "<html><head><title>Not found</title></head><body>File not found: ~a</body></html>"
file-path))]))))))
)