From 6d8b8a339061c975638b5799f06cebec16699742 Mon Sep 17 00:00:00 2001 From: Jens Axel Soegaard Date: Sat, 25 Aug 2007 19:08:33 +0000 Subject: [PATCH] Merged online HelpDesk into /collects/help 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 --- collects/help/help-desk.ss | 3 + collects/help/launch.ss | 36 ++ collects/help/private/colldocs.ss | 49 +- collects/help/private/docpos.ss | 3 +- collects/help/private/finddoc.ss | 75 +-- collects/help/private/get-help-url.ss | 9 +- collects/help/private/internal-hp.ss | 15 +- collects/help/private/manuals.ss | 371 ++++++------- collects/help/private/search.ss | 2 +- collects/help/private/standard-urls.ss | 30 +- collects/help/servlets/acknowledge.ss | 19 +- collects/help/servlets/doc-anchor.ss | 5 +- collects/help/servlets/doc-content.ss | 5 +- collects/help/servlets/doc-message.ss | 5 +- collects/help/servlets/home.ss | 506 ++++++++++++++++-- collects/help/servlets/howtoscheme.ss | 54 +- collects/help/servlets/manual-section.ss | 18 +- collects/help/servlets/missing-manual.ss | 52 +- collects/help/servlets/private/helpdesk.css | 6 + collects/help/servlets/private/html.ss | 187 +++++++ collects/help/servlets/private/platform.ss | 11 + collects/help/servlets/private/read-doc.ss | 11 +- .../help/servlets/private/split-screen.ss | 125 +++++ .../help/servlets/private/top-search-bar.ss | 0 collects/help/servlets/private/url.ss | 68 +++ collects/help/servlets/resources.ss | 53 +- collects/help/servlets/results.ss | 69 ++- collects/help/servlets/static.ss | 124 +++++ 28 files changed, 1449 insertions(+), 462 deletions(-) create mode 100644 collects/help/launch.ss create mode 100644 collects/help/servlets/private/helpdesk.css create mode 100644 collects/help/servlets/private/html.ss create mode 100644 collects/help/servlets/private/platform.ss create mode 100644 collects/help/servlets/private/split-screen.ss create mode 100644 collects/help/servlets/private/top-search-bar.ss create mode 100644 collects/help/servlets/private/url.ss create mode 100644 collects/help/servlets/static.ss diff --git a/collects/help/help-desk.ss b/collects/help/help-desk.ss index ca6231db38..7e25e9a7a1 100644 --- a/collects/help/help-desk.ss +++ b/collects/help/help-desk.ss @@ -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 diff --git a/collects/help/launch.ss b/collects/help/launch.ss new file mode 100644 index 0000000000..b89449859f --- /dev/null +++ b/collects/help/launch.ss @@ -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) diff --git a/collects/help/private/colldocs.ss b/collects/help/private/colldocs.ss index 89ae6457ae..33ec5d0806 100644 --- a/collects/help/private/colldocs.ss +++ b/collects/help/private/colldocs.ss @@ -4,41 +4,26 @@ (lib "contract.ss")) (define (colldocs) - (let loop ([dirrecs - (sort (find-relevant-directory-records '(doc.txt) 'all-available) - (lambda (a b) - (bytesbytes (directory-record-path a)) - (path->bytes (directory-record-path b)))))] + (let loop ([dirs (sort (map path->string (find-relevant-directories + '(doc.txt) 'all-available)) + stringpath 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?)) diff --git a/collects/help/private/docpos.ss b/collects/help/private/docpos.ss index 364ad70e67..eb2dcfdaa0 100644 --- a/collects/help/private/docpos.ss +++ b/collects/help/private/docpos.ss @@ -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)) diff --git a/collects/help/private/finddoc.ss b/collects/help/private/finddoc.ss index 42a28e98a4..b45415b59e 100644 --- a/collects/help/private/finddoc.ss +++ b/collects/help/private/finddoc.ss @@ -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" - (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/ (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/#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) diff --git a/collects/help/private/get-help-url.ss b/collects/help/private/get-help-url.ss index a727e743c0..e1fd89886a 100644 --- a/collects/help/private/get-help-url.ss +++ b/collects/help/private/get-help-url.ss @@ -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) diff --git a/collects/help/private/internal-hp.ss b/collects/help/private/internal-hp.ss index 1404a8191a..9d1ab94fd0 100644 --- a/collects/help/private/internal-hp.ss +++ b/collects/help/private/internal-hp.ss @@ -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)) diff --git a/collects/help/private/manuals.ss b/collects/help/private/manuals.ss index a9c6b9ae01..8c664f236f 100644 --- a/collects/help/private/manuals.ss +++ b/collects/help/private/manuals.ss @@ -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 - "" - (xexpr->string `(HEAD ,hd-css ,@hd-links (TITLE "PLT Manuals"))) - "" - - (append - - (list "

Installed Manuals

") - (if (repos-or-nightly-build?) - (list - "Subversion: " - (string-constant plt:hd:refresh-all-manuals) - "    " - (format "flush index and keyword cache
" flush-manuals-url)) - '()) - (build-known-manuals names+paths) - - (list "

Doc.txt

    ") - (doc.txt-manuals) - - (list "
") - - (let ([uninstalled (get-uninstalled docs)]) - (if (null? uninstalled) - `("") - `("

Uninstalled Manuals

" - "
    " - ,@(map - (lambda (doc-pair) - (let* ([manual (car doc-pair)] - [name (cdr doc-pair)] - [manual-path (find-doc-directory manual)]) - (string-append - "
  • Download and install path ,(path->bytes manual)) - ,name)))) - (format "\">~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) - "
"))) - (list ""))))) + (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 "
  • ~a" - (if (file-exists? path) - (format "~a" - ;; escape colons and other junk - (uri-encode (path->string path)) - (uri-encode name) - (uri-encode name) - name) - (format "~a: specified doc.txt file (~a) not found" - 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)] + [(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 - "

    " (sec-name sec) "

    " - "
      " - (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)))])))) - "
    "))) - - ;; 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 "
  • ~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 - "
      " - "" - (if (is-known-doc? doc-path) - (string-append - (format - "[~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)) - " ") - "") - (format (string-constant plt:hd:manual-installed-date) - (date->string - (seconds->date - (file-or-directory-modify-seconds - (build-path doc-path index-file))))) - "") - "")))) - + `(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->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]*") - + ;; 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) (stringstring 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?))])) diff --git a/collects/help/private/search.ss b/collects/help/private/search.ss index 8dcf76c6ed..5ef5af167c 100644 --- a/collects/help/private/search.ss +++ b/collects/help/private/search.ss @@ -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))) diff --git a/collects/help/private/standard-urls.ss b/collects/help/private/standard-urls.ss index ca46273c00..3608eaec39 100644 --- a/collects/help/private/standard-urls.ss +++ b/collects/help/private/standard-urls.ss @@ -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? diff --git a/collects/help/servlets/acknowledge.ss b/collects/help/servlets/acknowledge.ss index 02c2179053..a673825a1c 100644 --- a/collects/help/servlets/acknowledge.ss +++ b/collects/help/servlets/acknowledge.ss @@ -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))))))) \ No newline at end of file + (html-page + #:title "Acknowledgements" + #:bodies `((a ([name "acknowledgements"] [value "acknowledgements"])) + (h1 "Acknowledgements") + (p) + ,(get-general-acks) + (p) + ,(get-translating-acks))))))) diff --git a/collects/help/servlets/doc-anchor.ss b/collects/help/servlets/doc-anchor.ss index ee55c0898c..bd4766c84b 100644 --- a/collects/help/servlets/doc-anchor.ss +++ b/collects/help/servlets/doc-anchor.ss @@ -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)))))) \ No newline at end of file + offset)))))) + diff --git a/collects/help/servlets/doc-content.ss b/collects/help/servlets/doc-content.ss index 88bfd4c653..1eb5cb685b 100644 --- a/collects/help/servlets/doc-content.ss +++ b/collects/help/servlets/doc-content.ss @@ -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))))))) \ No newline at end of file + ,(read-lines file caption offset))))))) + \ No newline at end of file diff --git a/collects/help/servlets/doc-message.ss b/collects/help/servlets/doc-message.ss index c80af122a5..5e492034a2 100644 --- a/collects/help/servlets/doc-message.ss +++ b/collects/help/servlets/doc-message.ss @@ -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)))))))) \ No newline at end of file + (hr)))))))) + \ No newline at end of file diff --git a/collects/help/servlets/home.ss b/collects/help/servlets/home.ss index 66ca4b40f1..14f7752171 100644 --- a/collects/help/servlets/home.ss +++ b/collects/help/servlets/home.ss @@ -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))))))))))) \ No newline at end of file + (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.")))) + ))) \ No newline at end of file diff --git a/collects/help/servlets/howtoscheme.ss b/collects/help/servlets/howtoscheme.ss index d182a0d2f8..71adf73963 100644 --- a/collects/help/servlets/howtoscheme.ss +++ b/collects/help/servlets/howtoscheme.ss @@ -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")))))))) \ No newline at end of file + (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")))))))) diff --git a/collects/help/servlets/manual-section.ss b/collects/help/servlets/manual-section.ss index 979326e242..7ef8823c2a 100644 --- a/collects/help/servlets/manual-section.ss +++ b/collects/help/servlets/manual-section.ss @@ -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))))))) \ No newline at end of file + (send/finish (redirect-to page))))))) + \ No newline at end of file diff --git a/collects/help/servlets/missing-manual.ss b/collects/help/servlets/missing-manual.ss index 5a29290c01..c78808e491 100644 --- a/collects/help/servlets/missing-manual.ss +++ b/collects/help/servlets/missing-manual.ss @@ -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") + "."))))) diff --git a/collects/help/servlets/private/helpdesk.css b/collects/help/servlets/private/helpdesk.css new file mode 100644 index 0000000000..844d06d6d0 --- /dev/null +++ b/collects/help/servlets/private/helpdesk.css @@ -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; } diff --git a/collects/help/servlets/private/html.ss b/collects/help/servlets/private/html.ss new file mode 100644 index 0000000000..90f6973e93 --- /dev/null +++ b/collects/help/servlets/private/html.ss @@ -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)) + + ) \ No newline at end of file diff --git a/collects/help/servlets/private/platform.ss b/collects/help/servlets/private/platform.ss new file mode 100644 index 0000000000..e706c36dee --- /dev/null +++ b/collects/help/servlets/private/platform.ss @@ -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 + ))) \ No newline at end of file diff --git a/collects/help/servlets/private/read-doc.ss b/collects/help/servlets/private/read-doc.ss index 98cfc64cad..f3c3b416a8 100644 --- a/collects/help/servlets/private/read-doc.ss +++ b/collects/help/servlets/private/read-doc.ss @@ -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]) diff --git a/collects/help/servlets/private/split-screen.ss b/collects/help/servlets/private/split-screen.ss new file mode 100644 index 0000000000..a6e53d526d --- /dev/null +++ b/collects/help/servlets/private/split-screen.ss @@ -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) + +) \ No newline at end of file diff --git a/collects/help/servlets/private/top-search-bar.ss b/collects/help/servlets/private/top-search-bar.ss new file mode 100644 index 0000000000..e69de29bb2 diff --git a/collects/help/servlets/private/url.ss b/collects/help/servlets/private/url.ss new file mode 100644 index 0000000000..0d0f1e7e32 --- /dev/null +++ b/collects/help/servlets/private/url.ss @@ -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")) + + ) \ No newline at end of file diff --git a/collects/help/servlets/resources.ss b/collects/help/servlets/resources.ss index 26a9285d88..c580ec794f 100644 --- a/collects/help/servlets/resources.ss +++ b/collects/help/servlets/resources.ss @@ -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/") ".")))))) \ No newline at end of file + (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/") ".")))))) + \ No newline at end of file diff --git a/collects/help/servlets/results.ss b/collects/help/servlets/results.ss index d1d9ddb2ad..ecd8878864 100644 --- a/collects/help/servlets/results.ss +++ b/collects/help/servlets/results.ss @@ -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)))]))))))) + + \ No newline at end of file diff --git a/collects/help/servlets/static.ss b/collects/help/servlets/static.ss new file mode 100644 index 0000000000..f2a782c68f --- /dev/null +++ b/collects/help/servlets/static.ss @@ -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" + "Not foundFile not found.")] + [(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 "Not foundFile not found: ~a" + file-path))])))))) + + ) \ No newline at end of file