From 4cdddaec1a1f6800b3a701e95eb2d202a5aab198 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 30 May 2007 15:10:24 +0000 Subject: [PATCH] Removing obsolete functions and fixing report-errors-to-browser, which did not work svn: r6402 --- collects/help/servlets/acknowledge.ss | 18 +- collects/help/servlets/doc-anchor.ss | 20 +- collects/help/servlets/doc-content.ss | 24 +- collects/help/servlets/doc-message.ss | 14 +- collects/help/servlets/home.ss | 82 +-- collects/help/servlets/howtodrscheme.ss | 40 +- collects/help/servlets/howtoprogram.ss | 50 +- collects/help/servlets/howtoscheme.ss | 6 +- collects/help/servlets/howtouse.ss | 126 +++-- collects/help/servlets/manual-section.ss | 48 +- collects/help/servlets/manuals.ss | 6 +- collects/help/servlets/missing-manual.ss | 54 +- collects/help/servlets/release/bugs.ss | 6 +- collects/help/servlets/release/license.ss | 6 +- collects/help/servlets/release/notes.ss | 6 +- collects/help/servlets/release/patches.ss | 6 +- collects/help/servlets/releaseinfo.ss | 6 +- collects/help/servlets/research/why.ss | 6 +- collects/help/servlets/resources.ss | 6 +- collects/help/servlets/resources/libext.ss | 6 +- collects/help/servlets/resources/maillist.ss | 6 +- .../help/servlets/resources/teachscheme.ss | 6 +- collects/help/servlets/results.ss | 531 +++++++++--------- collects/help/servlets/scheme/doc.ss | 6 +- collects/help/servlets/scheme/how.ss | 6 +- collects/help/servlets/scheme/langlevels.ss | 6 +- collects/help/servlets/scheme/misc.ss | 28 +- collects/help/servlets/scheme/misc/activex.ss | 7 +- collects/help/servlets/scheme/misc/batch.ss | 8 +- collects/help/servlets/scheme/misc/cgi.ss | 284 +++++----- .../help/servlets/scheme/misc/database.ss | 49 +- .../help/servlets/scheme/misc/graphics.ss | 48 +- collects/help/servlets/scheme/misc/script.ss | 78 +-- .../help/servlets/scheme/misc/standalone.ss | 46 +- collects/help/servlets/scheme/misc/system.ss | 30 +- collects/help/servlets/scheme/what.ss | 186 +++--- collects/help/servlets/teachpacks.ss | 18 +- collects/htdp/servlet.ss | 21 +- .../servlets/examples/compound/helper.ss | 14 +- .../servlets/examples/compound/multiply.ss | 24 +- .../servlets/tests/cut-module.ss | 23 +- .../default-web-root/servlets/tests/error.ss | 11 + .../servlets/tests/incremental.ss | 3 +- .../servlets/tests/module-suspended-init.ss | 18 +- .../servlets/tests/new-suite/jas01-fix.ss | 14 - .../servlets/tests/new-suite/jas01.ss | 14 - .../servlets/tests/new-suite/pr5565.ss | 19 - .../servlets/tests/new-suite/pr7935-other.ss | 10 - .../servlets/tests/suspended-module.ss | 8 +- .../web-server/dispatchers/dispatch-host.ss | 21 +- collects/web-server/private/configure.ss | 13 + .../web-server/private/servlet-helpers.ss | 78 +-- .../lang-api/web-extras.ss | 80 +-- 53 files changed, 1110 insertions(+), 1140 deletions(-) create mode 100644 collects/web-server/default-web-root/servlets/tests/error.ss delete mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss delete mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss delete mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss delete mode 100644 collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss diff --git a/collects/help/servlets/acknowledge.ss b/collects/help/servlets/acknowledge.ss index ca24b6bc52..02c2179053 100644 --- a/collects/help/servlets/acknowledge.ss +++ b/collects/help/servlets/acknowledge.ss @@ -6,11 +6,13 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - `(html (head (title "Acknowledgements")) - (body (a ([name "acknowledgements"] [value "acknowledgements"])) - (h1 "Acknowledgements") - (p) - ,(get-general-acks) - (p) - ,(get-translating-acks))))) + (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 diff --git a/collects/help/servlets/doc-anchor.ss b/collects/help/servlets/doc-anchor.ss index 7344c7f194..ee55c0898c 100644 --- a/collects/help/servlets/doc-anchor.ss +++ b/collects/help/servlets/doc-anchor.ss @@ -5,12 +5,14 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - (let* ([bindings (request-bindings initial-request)] - [offset (with-handlers ((void (lambda _ #f))) - (string->number - (extract-binding/single 'offset bindings)))]) - (read-doc (extract-binding/single 'file bindings) - (extract-binding/single 'caption bindings) - (extract-binding/single 'name bindings) - offset)))) + (with-errors-to-browser + send/finish + (lambda () + (let* ([bindings (request-bindings initial-request)] + [offset (with-handlers ((void (lambda _ #f))) + (string->number + (extract-binding/single 'offset bindings)))]) + (read-doc (extract-binding/single 'file bindings) + (extract-binding/single 'caption bindings) + (extract-binding/single 'name bindings) + offset)))))) \ No newline at end of file diff --git a/collects/help/servlets/doc-content.ss b/collects/help/servlets/doc-content.ss index 36f53ff8bc..88bfd4c653 100644 --- a/collects/help/servlets/doc-content.ss +++ b/collects/help/servlets/doc-content.ss @@ -6,14 +6,16 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - (let* ([bindings (request-bindings initial-request)] - [file (extract-binding/single 'file bindings)] - [caption (extract-binding/single 'caption bindings)] - [offset (with-handlers ((void (lambda _ #f))) - (string->number - (extract-binding/single 'offset bindings)))]) - `(html (head (title "PLT Help Desk") - ,hd-css - ,@hd-links) - ,(read-lines file caption offset))))) + (with-errors-to-browser + send/finish + (lambda () + (let* ([bindings (request-bindings initial-request)] + [file (extract-binding/single 'file bindings)] + [caption (extract-binding/single 'caption bindings)] + [offset (with-handlers ((void (lambda _ #f))) + (string->number + (extract-binding/single 'offset bindings)))]) + `(html (head (title "PLT Help Desk") + ,hd-css + ,@hd-links) + ,(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 9267310908..c80af122a5 100644 --- a/collects/help/servlets/doc-message.ss +++ b/collects/help/servlets/doc-message.ss @@ -6,9 +6,11 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - (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)))))) + (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 diff --git a/collects/help/servlets/home.ss b/collects/help/servlets/home.ss index bcb559f518..66ca4b40f1 100644 --- a/collects/help/servlets/home.ss +++ b/collects/help/servlets/home.ss @@ -3,29 +3,29 @@ "../private/get-help-url.ss" "../private/manuals.ss" (lib "servlet.ss" "web-server")) - + (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"))) + ,(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")) + ("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")))) - + ("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] @@ -33,29 +33,31 @@ [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)))) - + ,@(if (null? subs) + '() + `((br) nbsp nbsp nbsp nbsp nbsp nbsp + (font ([size "-2"]) + ,@(apply append (map (lambda (s) `(,(item->xexpr s) ", ")) + subs)) + "..."))) + (br) (br)))) + (define (start initial-request) - (report-errors-to-browser send/finish) - `(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))))))))) + (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 diff --git a/collects/help/servlets/howtodrscheme.ss b/collects/help/servlets/howtodrscheme.ss index a43110486a..fb5d0183bb 100644 --- a/collects/help/servlets/howtodrscheme.ss +++ b/collects/help/servlets/howtodrscheme.ss @@ -6,22 +6,24 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - `(html - (head ,hd-css ,@hd-links (title "DrScheme")) - (body - (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")))))) + (with-errors-to-browser + send/finish + (lambda () + `(html + (head ,hd-css ,@hd-links (title "DrScheme")) + (body + (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")))))))) \ No newline at end of file diff --git a/collects/help/servlets/howtoprogram.ss b/collects/help/servlets/howtoprogram.ss index 92b4f61fe8..a882e0b745 100644 --- a/collects/help/servlets/howtoprogram.ss +++ b/collects/help/servlets/howtoprogram.ss @@ -7,27 +7,29 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - `(html - (head ,hd-css ,@hd-links (title "Program Design")) - (body - (h1 "Program Design") - ,(color-highlight `(h2 "For Students")) - "The textbook " (i "How to Design Programs") - " provides an introduction to programming using the DrScheme" - " environment. The book is not distributed with DrScheme, but it" - " is available online at " - (pre " " (a ([href "http://www.htdp.org/"] [target "_top"]) - "http://www.htdp.org/")) - (p) - "Help Desk provides the following interactive support for the textbook:" - (ul (li (b (a ([href "/servlets/teachpacks.ss"]) - "Teachpack documentation")))) - (p) - ,(color-highlight `(h2 "For Experienced Programmers")) - (ul (li (b (a ((href ,(get-manual-index "t-y-scheme"))) - "Teach Yourself Scheme in Fixnum Days")) - ": For programmers with lots of experience in other languages")) - ,(color-highlight `(h2 "For Teachers and Researchers")) - (ul (li (b (a ([href "/servlets/research/why.ss"]) "Why DrScheme?")) - ": PLT's vision ")))))) + (with-errors-to-browser + send/finish + (lambda () + `(html + (head ,hd-css ,@hd-links (title "Program Design")) + (body + (h1 "Program Design") + ,(color-highlight `(h2 "For Students")) + "The textbook " (i "How to Design Programs") + " provides an introduction to programming using the DrScheme" + " environment. The book is not distributed with DrScheme, but it" + " is available online at " + (pre " " (a ([href "http://www.htdp.org/"] [target "_top"]) + "http://www.htdp.org/")) + (p) + "Help Desk provides the following interactive support for the textbook:" + (ul (li (b (a ([href "/servlets/teachpacks.ss"]) + "Teachpack documentation")))) + (p) + ,(color-highlight `(h2 "For Experienced Programmers")) + (ul (li (b (a ((href ,(get-manual-index "t-y-scheme"))) + "Teach Yourself Scheme in Fixnum Days")) + ": For programmers with lots of experience in other languages")) + ,(color-highlight `(h2 "For Teachers and Researchers")) + (ul (li (b (a ([href "/servlets/research/why.ss"]) "Why DrScheme?")) + ": PLT's vision ")))))))) \ No newline at end of file diff --git a/collects/help/servlets/howtoscheme.ss b/collects/help/servlets/howtoscheme.ss index 98bfa74dd9..d182a0d2f8 100644 --- a/collects/help/servlets/howtoscheme.ss +++ b/collects/help/servlets/howtoscheme.ss @@ -6,7 +6,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Software")) (body @@ -33,4 +35,4 @@ (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")))))) + ": License, notes, and known bugs")))))))) \ No newline at end of file diff --git a/collects/help/servlets/howtouse.ss b/collects/help/servlets/howtouse.ss index 89c206909a..13561310fd 100644 --- a/collects/help/servlets/howtouse.ss +++ b/collects/help/servlets/howtouse.ss @@ -7,65 +7,67 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - `(html - (head ,hd-css ,@hd-links (title "Help Desk")) - (body - (h1 "Help Desk") - (p) - (a ([name "helpme"] [value "Help Desk"])) - "Help Desk (the program you're currently running) is a " - "complete source of information about PLT software, " - "including DrScheme, MzScheme, and MrEd." - (p) - "Use Help Desk to find information in either of two ways:" - (p) - ,(color-highlight - "1. Navigate the Help Desk information pages by" - " clicking on hyperlinks.") - (ul - (li "The " (b ,(string-constant home)) " button " - "at the top of the page always takes " - "you back to the starting page.") - (li "The " (b "Manuals") " link (in the " (b "Software") " section on the main page) displays a list" - " of manuals and other documentation.") - (li "The " (b "Send a bug report") - " link allows you to submit bug reports to PLT.")) - (p) - (a ([name "helpsearch"] [value "Searching in Help Desk"])) - (a ([name "search"])) - ,(color-highlight - "2. Search for terms using the " - `(b "Find docs for") " field at the bottom of Help Desk.") - (ul - (li "Enter one or more terms into the " (b "Find docs for") " field.") - (li "Click the " (b "Search") " button " - "(or hit Enter) to start a search, " - "or choose the " (b "Feeling Lucky") " menu item.") - (li "If you click on the " (b "Search") " button, " - "Help Desk scans the documentation pages and " - "returns a list of hyperlinks for " - (i "keyword") ", " - (i "index entry") ", and " - (i "raw text") " matches:" - (ul (li (i "Keywords") " are Scheme names, such as " (tt "define") - " and " (tt "cons") ".") - (li (i "Index entries") - " are topical phrases, such as \"lists\".") - (li (i "Raw text") " results are fragments of " - "text from the documentation pages. " - "(Raw text results are useful only as " - "a last resort.)"))) - (li "If you perform a lucky search, " - "Help Desk goes directly to the first item of documentation " - "that matches the search term, without displaying links to " - "all relevant items.")) - (p) - "Help Desk sorts search results according to their source." - (p) - "If you open Help Desk inside DrScheme, the search results are " - "filtered based on the language you are using. Use " - (b "Choose Language...") - " menu item from the " - (b "Language") - " menu to change the language.")))) + (with-errors-to-browser + send/finish + (lambda () + `(html + (head ,hd-css ,@hd-links (title "Help Desk")) + (body + (h1 "Help Desk") + (p) + (a ([name "helpme"] [value "Help Desk"])) + "Help Desk (the program you're currently running) is a " + "complete source of information about PLT software, " + "including DrScheme, MzScheme, and MrEd." + (p) + "Use Help Desk to find information in either of two ways:" + (p) + ,(color-highlight + "1. Navigate the Help Desk information pages by" + " clicking on hyperlinks.") + (ul + (li "The " (b ,(string-constant home)) " button " + "at the top of the page always takes " + "you back to the starting page.") + (li "The " (b "Manuals") " link (in the " (b "Software") " section on the main page) displays a list" + " of manuals and other documentation.") + (li "The " (b "Send a bug report") + " link allows you to submit bug reports to PLT.")) + (p) + (a ([name "helpsearch"] [value "Searching in Help Desk"])) + (a ([name "search"])) + ,(color-highlight + "2. Search for terms using the " + `(b "Find docs for") " field at the bottom of Help Desk.") + (ul + (li "Enter one or more terms into the " (b "Find docs for") " field.") + (li "Click the " (b "Search") " button " + "(or hit Enter) to start a search, " + "or choose the " (b "Feeling Lucky") " menu item.") + (li "If you click on the " (b "Search") " button, " + "Help Desk scans the documentation pages and " + "returns a list of hyperlinks for " + (i "keyword") ", " + (i "index entry") ", and " + (i "raw text") " matches:" + (ul (li (i "Keywords") " are Scheme names, such as " (tt "define") + " and " (tt "cons") ".") + (li (i "Index entries") + " are topical phrases, such as \"lists\".") + (li (i "Raw text") " results are fragments of " + "text from the documentation pages. " + "(Raw text results are useful only as " + "a last resort.)"))) + (li "If you perform a lucky search, " + "Help Desk goes directly to the first item of documentation " + "that matches the search term, without displaying links to " + "all relevant items.")) + (p) + "Help Desk sorts search results according to their source." + (p) + "If you open Help Desk inside DrScheme, the search results are " + "filtered based on the language you are using. Use " + (b "Choose Language...") + " menu item from the " + (b "Language") + " menu to change the language.")))))) \ No newline at end of file diff --git a/collects/help/servlets/manual-section.ss b/collects/help/servlets/manual-section.ss index 3240bcc26b..979326e242 100644 --- a/collects/help/servlets/manual-section.ss +++ b/collects/help/servlets/manual-section.ss @@ -5,27 +5,29 @@ (provide interface-version timeout start) (define interface-version 'v1) (define timeout +inf.0) - + (define (start initial-request) - (report-errors-to-browser send/finish) - (let* ([bindings (request-bindings initial-request)] - [manual (extract-binding/single 'manual bindings)] - [raw-section (extract-binding/single 'section bindings)] - ;; remove quotes - [section (substring raw-section - 1 (sub1 (string-length raw-section)))] - [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" - (p) - "Requested manual: " - ,manual (br) - "Requested section: " - ,section))))]) - (finddoc-page-anchor manual section))]) - (send/finish (redirect-to page))))) + (with-errors-to-browser + send/finish + (lambda () + (let* ([bindings (request-bindings initial-request)] + [manual (extract-binding/single 'manual bindings)] + [raw-section (extract-binding/single 'section bindings)] + ;; remove quotes + [section (substring raw-section + 1 (sub1 (string-length raw-section)))] + [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" + (p) + "Requested manual: " + ,manual (br) + "Requested section: " + ,section))))]) + (finddoc-page-anchor manual section))]) + (send/finish (redirect-to page))))))) \ No newline at end of file diff --git a/collects/help/servlets/manuals.ss b/collects/help/servlets/manuals.ss index 6d5db4e811..9008e5bbf6 100644 --- a/collects/help/servlets/manuals.ss +++ b/collects/help/servlets/manuals.ss @@ -5,5 +5,7 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - (list #"text/html" (find-manuals)))) + (with-errors-to-browser + send/finish + (lambda () + (list #"text/html" (find-manuals)))))) \ No newline at end of file diff --git a/collects/help/servlets/missing-manual.ss b/collects/help/servlets/missing-manual.ss index 07caf8ca0a..5a29290c01 100644 --- a/collects/help/servlets/missing-manual.ss +++ b/collects/help/servlets/missing-manual.ss @@ -6,36 +6,38 @@ (provide interface-version timeout start) (define interface-version 'v1) (define timeout +inf.0) - + (define (start initial-request) - (report-errors-to-browser send/finish) - (let ([bindings (request-bindings initial-request)]) - (no-manual (extract-binding/single 'manual bindings) - (extract-binding/single 'name bindings) - (extract-binding/single 'link bindings)))) - + (with-errors-to-browser + send/finish + (lambda () + (let ([bindings (request-bindings initial-request)]) + (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") - "."))))) + ,(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/release/bugs.ss b/collects/help/servlets/release/bugs.ss index 3285db357b..aabb6ae486 100644 --- a/collects/help/servlets/release/bugs.ss +++ b/collects/help/servlets/release/bugs.ss @@ -7,7 +7,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Known Bugs")) (body @@ -15,4 +17,4 @@ (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")) "."))) + "PLT bug report query page")) "."))))) \ No newline at end of file diff --git a/collects/help/servlets/release/license.ss b/collects/help/servlets/release/license.ss index 954fe8673a..efe73f1d7c 100644 --- a/collects/help/servlets/release/license.ss +++ b/collects/help/servlets/release/license.ss @@ -11,7 +11,9 @@ `(ul (li ,@(map (lambda (s) `(div ,s (br))) ss)))) (define copyright-year 2007) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "License")) (body @@ -88,4 +90,4 @@ ("GNU lightning" "Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.") ("GNU Classpath" - "GNU Public License with special exception"))))))) + "GNU Public License with special exception"))))))))) \ No newline at end of file diff --git a/collects/help/servlets/release/notes.ss b/collects/help/servlets/release/notes.ss index f8c8ca7e56..f458934326 100644 --- a/collects/help/servlets/release/notes.ss +++ b/collects/help/servlets/release/notes.ss @@ -22,7 +22,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "PLT release notes")) (body @@ -39,4 +41,4 @@ ("MzScheme release notes" "mzscheme" "HISTORY") ("MrEd release notes" "mred" "HISTORY") ("Stepper release notes" "stepper" "HISTORY") - ("MrFlow release notes" "mrflow" "HISTORY"))))))))) + ("MrFlow release notes" "mrflow" "HISTORY"))))))))))) \ No newline at end of file diff --git a/collects/help/servlets/release/patches.ss b/collects/help/servlets/release/patches.ss index 42b6ddb130..4bd02ee7a9 100644 --- a/collects/help/servlets/release/patches.ss +++ b/collects/help/servlets/release/patches.ss @@ -6,7 +6,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Downloadable Patches")) (body @@ -18,4 +20,4 @@ nbsp nbsp ,(let ([url (format "http://download.plt-scheme.org/patches/~a/" (version))]) - `(a ([href ,url] [target "_top"]) ,url)))))) + `(a ([href ,url] [target "_top"]) ,url)))))))) \ No newline at end of file diff --git a/collects/help/servlets/releaseinfo.ss b/collects/help/servlets/releaseinfo.ss index eb641ee305..f459d8f853 100644 --- a/collects/help/servlets/releaseinfo.ss +++ b/collects/help/servlets/releaseinfo.ss @@ -10,7 +10,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Release Information")) (body @@ -29,4 +31,4 @@ (pre nbsp nbsp ,(let-values ([(base file dir?) (split-path (collection-path "mzlib"))]) - (path->string base))))))) + (path->string base))))))))) \ No newline at end of file diff --git a/collects/help/servlets/research/why.ss b/collects/help/servlets/research/why.ss index cbc98cd590..4a719c1dc4 100644 --- a/collects/help/servlets/research/why.ss +++ b/collects/help/servlets/research/why.ss @@ -6,7 +6,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Why DrScheme?")) (body @@ -57,4 +59,4 @@ " paper: " (a ([href "http://www.ccs.neu.edu/scheme/pubs#jfp01-fcffksf"] [target "_top"]) - "DrScheme: A Programming Environment for Scheme") ".")))) + "DrScheme: A Programming Environment for Scheme") ".")))))) \ No newline at end of file diff --git a/collects/help/servlets/resources.ss b/collects/help/servlets/resources.ss index e1ede38993..26a9285d88 100644 --- a/collects/help/servlets/resources.ss +++ b/collects/help/servlets/resources.ss @@ -5,7 +5,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "External Resources")) (body @@ -29,4 +31,4 @@ "many Scheme resources, including books, implementations, " "and libraries: " (a ([href "http://www.schemers.org/"] [target "_top"]) - "http://www.schemers.org/") ".")))) + "http://www.schemers.org/") ".")))))) \ No newline at end of file diff --git a/collects/help/servlets/resources/libext.ss b/collects/help/servlets/resources/libext.ss index 952ab6a763..9bb6e9414e 100644 --- a/collects/help/servlets/resources/libext.ss +++ b/collects/help/servlets/resources/libext.ss @@ -6,7 +6,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Libraries")) (body @@ -30,4 +32,4 @@ "If you write a PLT library or extension, we would like to hear about" " it! Please send a message about it to Matthew Flatt at " (TT "mflatt@cs.utah.edu") " so we can list it. " - "Thanks for your efforts!")))) + "Thanks for your efforts!")))))) \ No newline at end of file diff --git a/collects/help/servlets/resources/maillist.ss b/collects/help/servlets/resources/maillist.ss index d923861c32..2edf37e053 100644 --- a/collects/help/servlets/resources/maillist.ss +++ b/collects/help/servlets/resources/maillist.ss @@ -5,7 +5,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Mailing Lists")) (body @@ -79,4 +81,4 @@ (a ([href "mailto:plt-scheme-es-request@list.cs.brown.edu"]) "plt-scheme-es-request@list.cs.brown.edu")) " con la palabra `help' en el asunto o en el cuerpo de tu mensaje. " - "Recibirás un mensaje de regreso con instrucciones.")))) + "Recibirás un mensaje de regreso con instrucciones.")))))) \ No newline at end of file diff --git a/collects/help/servlets/resources/teachscheme.ss b/collects/help/servlets/resources/teachscheme.ss index 305be60f48..c0fbc97cd0 100644 --- a/collects/help/servlets/resources/teachscheme.ss +++ b/collects/help/servlets/resources/teachscheme.ss @@ -5,7 +5,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "TeachScheme! Workshops")) (body @@ -28,4 +30,4 @@ "For more information, see the " (a ([href "http://www.teach-scheme.org/Workshops/"] [TARGET "_top"]) - "TeachScheme! Workshops page") ".")))) + "TeachScheme! Workshops page") ".")))))) \ No newline at end of file diff --git a/collects/help/servlets/results.ss b/collects/help/servlets/results.ss index 6b7a336305..d1d9ddb2ad 100644 --- a/collects/help/servlets/results.ss +++ b/collects/help/servlets/results.ss @@ -27,269 +27,270 @@ is stored in a module top-level and that's namespace-specific. (provide interface-version timeout start) (define interface-version 'v1) (define timeout +inf.0) - + (define (start initial-request) - (report-errors-to-browser send/finish) - (let () - ;; doc subcollection name -> boolean - (define (search-type->search-level st) - (let loop ([n 0] [lst (map car search-types)]) - (when (null? lst) (raise 'bad-search-type)) - (if (string=? (car lst) st) n (loop (add1 n) (cdr lst))))) - - (define search-responses #f) - - ;; from what I can tell, this variable doesn't work as intended. - ;; I've left it in for now, but this whole file needs to be rewritten. - ;; -robby - (define current-kind #f) - - (define last-header #f) - - (define max-reached #f) - (define (build-maxxed-out k) - (lambda () - (unless max-reached - (set! max-reached #t) - (set! search-responses - (cons `(b ,(with-color - "red" - (string-constant - plt:hd:search-stopped-too-many-matches))) - search-responses))) - (k #f))) - - (define (add-header s key) - (unless max-reached - (set! last-header s) - (set! search-responses - (list* `(b ([style "font-family:Verdana,Helvetica,sans-serif"]) - ,s) - `(br) - search-responses)))) - - (define (set-current-kind! s key) - (set! current-kind (cadr (assoc s kind-types)))) - - (define exp-web-root - (explode-path (normalize-path (find-collects-dir)))) - (define web-root-len (length exp-web-root)) - - (define (keyword-string? ekey) - (and (string? ekey) - (not (string=? ekey "")))) - - (define (pretty-label label ekey) - (if (keyword-string? ekey) - `(font ([face "monospace"]) - ;; boldface keyword occurrences - ,@(let ([mpos (regexp-match-positions (non-regexp ekey) label)]) - (if mpos - (let* ([item (car mpos)] - [start (car item)] - [stop (cdr item)]) - (list (substring label 0 start) - `(b ,(substring label start stop)) - (substring label stop (string-length label)))) - (list label)))) - label)) - - (define (maybe-extract-coll s) - (let ([len (string-length s)]) - (if (and (> len 17) - (string=? (substring s 0 4) "the ") - (string=? (substring s (- len 11) len) " collection")) - (substring s 4 (- len 11)) - s))) - - (define no-anchor-format - (string-append "/servlets/doc-anchor.ss?" - "file=~a&" - "caption=~a&" - "name=~a")) - - (define with-anchor-format - (string-append no-anchor-format "&offset=~a#temp")) - - (define (make-caption coll) - (format "Documentation for the ~a collection" coll)) - - (define (make-search-link href label src ekey) - `(table ([cellspacing "0"] [cellpadding "0"]) - (tr (td (div ([align "left-outdent"]) - (a ([href ,href]) ,(pretty-label label ekey)) - " in \"" ,src "\""))))) - - ;; doc-txt? : string -> boolean - (define (doc-txt? str) (regexp-match "doc\\.txt$" str)) - - (define (make-html-href page-label path) - (let ([anchored-path (make-anchored-path page-label path)]) - (cond [(servlet-path? path) anchored-path] - [(doc-txt? (path->string path)) ; collection doc.txt - (let ([maybe-coll (maybe-extract-coll last-header)]) - (format no-anchor-format - (uri-encode anchored-path) - (uri-encode (make-caption maybe-coll)) - maybe-coll))] - [else ; manual, so have absolute path - (get-help-url path page-label)]))) - - ;; make-anchored-path : string path -> string - ;; page-label is #f or a bytes that labels an HTML anchor - ;; path is either an absolute pathname (possibly not normalized) - ;; in the format of the native OS, or, in the case of Help Desk - ;; servlets, a forward-slashified path beginning with "/servlets/" - (define (make-anchored-path page-label path) - (let ([normal-path - (if (servlet-path? path) - path - (normalize-path path))]) - (if (and page-label - (string? page-label) - (not (or (string=? page-label "NO TAG") - (regexp-match "\\?|&" page-label)))) - (string-append (path->string normal-path) "#" page-label) - (path->string normal-path)))) - - ; path is absolute pathname - (define (make-text-href page-label path) - (let* ([maybe-coll (maybe-extract-coll last-header)] - [hex-path (uri-encode (path->string (normalize-path path)))] - [hex-caption (if (eq? maybe-coll last-header) - hex-path - (uri-encode (make-caption maybe-coll)))] - [offset (or (and (number? page-label) page-label) - 0)]) - (format with-anchor-format - hex-path hex-caption (uri-encode maybe-coll) offset))) - - (define (html-entry? path) - (and (not (suffixed? path #"doc.txt")) - (or (eq? current-kind 'html) (suffixed? path #".html")))) - - (define (suffixed? path suffix) - (let* ([path-bytes (path->bytes path)] - [path-len (bytes-length path-bytes)] - [suffix-len (bytes-length suffix)]) - (and (path-len . >= . suffix-len) - (bytes=? (subbytes path-bytes (- path-len suffix-len) path-len) - suffix)))) - - (define (goto-lucky-entry ekey label src path page-label key) - (let ([href (if (html-entry? path) - (make-html-href page-label path) - (make-text-href page-label path))]) - (send/finish (redirect-to href)))) - - (define (add-entry ekey label src path page-label key) - (let* ([entry - (if (html-entry? path) - (make-search-link (make-html-href page-label path) - label src ekey) - (make-search-link (make-text-href page-label path) - label src ekey))]) - (set! search-responses (cons entry search-responses)))) - - (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") - (h2 - ,@(if lang-name - (list "Language: " (with-color "firebrick" lang-name) '(br)) - '()) - ,@(let ([single-key - (lambda (sf) - (with-color "firebrick" (format " \"~a\"" sf)))]) - (cond [(null? string-finds) '()] - [(null? (cdr string-finds)) - (list "Key: " (single-key (car string-finds)))] - [else - (cons "Keys: " (map single-key string-finds))]))) - (br) - ,@items)))) - - (define (search-results lucky? search-string search-type match-type - manuals doc-txt? lang-name) - (set! search-responses '()) - (set! max-reached #f) - (let* ([search-level (search-type->search-level search-type)] - [regexp? (string=? match-type "regexp-match")] - [exact-match? (string=? match-type "exact-match")] - [key (gensym)] - [result (let/ec k - (do-search search-string - search-level - regexp? - exact-match? - manuals - doc-txt? - key - (build-maxxed-out k) - add-header - set-current-kind! - (if lucky? goto-lucky-entry add-entry)))] - [html (make-results-page - search-string - lang-name - (if (string? result) ; error message - `((h2 ([style "color:red"]) ,result)) - (reverse search-responses)) - regexp? - exact-match?)]) - html)) - - (define empty-search-page - `(html (head (title "Empty search string in PLT Help Desk")) - (body (h2 "Empty search string")))) - - (define (lucky-search? bindings) - (with-handlers ([exn:fail? (lambda _ #f)]) - (let ([result (extract-binding/single 'lucky bindings)]) - (not (string=? result "false"))))) - - (define (maybe-update-box b s) - (unless (string=? s "") (set-box! b s))) - - (define (convert-manuals manuals) - (if manuals - (let ([parsed (read-from-string manuals)]) - (if (and (list? parsed) (andmap bytes? parsed)) - (map bytes->path parsed) - (map car (find-doc-names)))) - (map car (find-doc-names)))) - - (let* ([bindings (request-bindings initial-request)] - [maybe-get (lambda (sym) - (with-handlers ([exn:fail? - (lambda (_) #f)]) - (extract-binding/single sym bindings)))] - [flush (maybe-get 'flush)]) - (cond - [flush - (doc-collections-changed) - `(html (head (title "Flush")) - (body (h2 "Flushed documentation cache")))] - [else - (let ([search-string (maybe-get 'search-string)] - [search-type (maybe-get 'search-type)] - [match-type (maybe-get 'match-type)] - [manuals (maybe-get 'manuals)] - [doc.txt (maybe-get 'doctxt)] - [lang-name (maybe-get 'langname)]) - (if (or (not search-string) (= (string-length search-string) 0)) - empty-search-page - (search-results (lucky-search? bindings) - search-string - (or search-type "keyword-index") - (or match-type "containing-match") - (convert-manuals manuals) - (cond [(not doc.txt) #t] - [(equal? doc.txt "false") #f] - [else #t]) - lang-name)))]))))) - + (with-errors-to-browser + send/finish + (lambda () + (let () + ;; doc subcollection name -> boolean + (define (search-type->search-level st) + (let loop ([n 0] [lst (map car search-types)]) + (when (null? lst) (raise 'bad-search-type)) + (if (string=? (car lst) st) n (loop (add1 n) (cdr lst))))) + + (define search-responses #f) + + ;; from what I can tell, this variable doesn't work as intended. + ;; I've left it in for now, but this whole file needs to be rewritten. + ;; -robby + (define current-kind #f) + + (define last-header #f) + + (define max-reached #f) + (define (build-maxxed-out k) + (lambda () + (unless max-reached + (set! max-reached #t) + (set! search-responses + (cons `(b ,(with-color + "red" + (string-constant + plt:hd:search-stopped-too-many-matches))) + search-responses))) + (k #f))) + + (define (add-header s key) + (unless max-reached + (set! last-header s) + (set! search-responses + (list* `(b ([style "font-family:Verdana,Helvetica,sans-serif"]) + ,s) + `(br) + search-responses)))) + + (define (set-current-kind! s key) + (set! current-kind (cadr (assoc s kind-types)))) + + (define exp-web-root + (explode-path (normalize-path (find-collects-dir)))) + (define web-root-len (length exp-web-root)) + + (define (keyword-string? ekey) + (and (string? ekey) + (not (string=? ekey "")))) + + (define (pretty-label label ekey) + (if (keyword-string? ekey) + `(font ([face "monospace"]) + ;; boldface keyword occurrences + ,@(let ([mpos (regexp-match-positions (non-regexp ekey) label)]) + (if mpos + (let* ([item (car mpos)] + [start (car item)] + [stop (cdr item)]) + (list (substring label 0 start) + `(b ,(substring label start stop)) + (substring label stop (string-length label)))) + (list label)))) + label)) + + (define (maybe-extract-coll s) + (let ([len (string-length s)]) + (if (and (> len 17) + (string=? (substring s 0 4) "the ") + (string=? (substring s (- len 11) len) " collection")) + (substring s 4 (- len 11)) + s))) + + (define no-anchor-format + (string-append "/servlets/doc-anchor.ss?" + "file=~a&" + "caption=~a&" + "name=~a")) + + (define with-anchor-format + (string-append no-anchor-format "&offset=~a#temp")) + + (define (make-caption coll) + (format "Documentation for the ~a collection" coll)) + + (define (make-search-link href label src ekey) + `(table ([cellspacing "0"] [cellpadding "0"]) + (tr (td (div ([align "left-outdent"]) + (a ([href ,href]) ,(pretty-label label ekey)) + " in \"" ,src "\""))))) + + ;; doc-txt? : string -> boolean + (define (doc-txt? str) (regexp-match "doc\\.txt$" str)) + + (define (make-html-href page-label path) + (let ([anchored-path (make-anchored-path page-label path)]) + (cond [(servlet-path? path) anchored-path] + [(doc-txt? (path->string path)) ; collection doc.txt + (let ([maybe-coll (maybe-extract-coll last-header)]) + (format no-anchor-format + (uri-encode anchored-path) + (uri-encode (make-caption maybe-coll)) + maybe-coll))] + [else ; manual, so have absolute path + (get-help-url path page-label)]))) + + ;; make-anchored-path : string path -> string + ;; page-label is #f or a bytes that labels an HTML anchor + ;; path is either an absolute pathname (possibly not normalized) + ;; in the format of the native OS, or, in the case of Help Desk + ;; servlets, a forward-slashified path beginning with "/servlets/" + (define (make-anchored-path page-label path) + (let ([normal-path + (if (servlet-path? path) + path + (normalize-path path))]) + (if (and page-label + (string? page-label) + (not (or (string=? page-label "NO TAG") + (regexp-match "\\?|&" page-label)))) + (string-append (path->string normal-path) "#" page-label) + (path->string normal-path)))) + + ; path is absolute pathname + (define (make-text-href page-label path) + (let* ([maybe-coll (maybe-extract-coll last-header)] + [hex-path (uri-encode (path->string (normalize-path path)))] + [hex-caption (if (eq? maybe-coll last-header) + hex-path + (uri-encode (make-caption maybe-coll)))] + [offset (or (and (number? page-label) page-label) + 0)]) + (format with-anchor-format + hex-path hex-caption (uri-encode maybe-coll) offset))) + + (define (html-entry? path) + (and (not (suffixed? path #"doc.txt")) + (or (eq? current-kind 'html) (suffixed? path #".html")))) + + (define (suffixed? path suffix) + (let* ([path-bytes (path->bytes path)] + [path-len (bytes-length path-bytes)] + [suffix-len (bytes-length suffix)]) + (and (path-len . >= . suffix-len) + (bytes=? (subbytes path-bytes (- path-len suffix-len) path-len) + suffix)))) + + (define (goto-lucky-entry ekey label src path page-label key) + (let ([href (if (html-entry? path) + (make-html-href page-label path) + (make-text-href page-label path))]) + (send/finish (redirect-to href)))) + + (define (add-entry ekey label src path page-label key) + (let* ([entry + (if (html-entry? path) + (make-search-link (make-html-href page-label path) + label src ekey) + (make-search-link (make-text-href page-label path) + label src ekey))]) + (set! search-responses (cons entry search-responses)))) + + (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") + (h2 + ,@(if lang-name + (list "Language: " (with-color "firebrick" lang-name) '(br)) + '()) + ,@(let ([single-key + (lambda (sf) + (with-color "firebrick" (format " \"~a\"" sf)))]) + (cond [(null? string-finds) '()] + [(null? (cdr string-finds)) + (list "Key: " (single-key (car string-finds)))] + [else + (cons "Keys: " (map single-key string-finds))]))) + (br) + ,@items)))) + + (define (search-results lucky? search-string search-type match-type + manuals doc-txt? lang-name) + (set! search-responses '()) + (set! max-reached #f) + (let* ([search-level (search-type->search-level search-type)] + [regexp? (string=? match-type "regexp-match")] + [exact-match? (string=? match-type "exact-match")] + [key (gensym)] + [result (let/ec k + (do-search search-string + search-level + regexp? + exact-match? + manuals + doc-txt? + key + (build-maxxed-out k) + add-header + set-current-kind! + (if lucky? goto-lucky-entry add-entry)))] + [html (make-results-page + search-string + lang-name + (if (string? result) ; error message + `((h2 ([style "color:red"]) ,result)) + (reverse search-responses)) + regexp? + exact-match?)]) + html)) + + (define empty-search-page + `(html (head (title "Empty search string in PLT Help Desk")) + (body (h2 "Empty search string")))) + + (define (lucky-search? bindings) + (with-handlers ([exn:fail? (lambda _ #f)]) + (let ([result (extract-binding/single 'lucky bindings)]) + (not (string=? result "false"))))) + + (define (maybe-update-box b s) + (unless (string=? s "") (set-box! b s))) + + (define (convert-manuals manuals) + (if manuals + (let ([parsed (read-from-string manuals)]) + (if (and (list? parsed) (andmap bytes? parsed)) + (map bytes->path parsed) + (map car (find-doc-names)))) + (map car (find-doc-names)))) + + (let* ([bindings (request-bindings initial-request)] + [maybe-get (lambda (sym) + (with-handlers ([exn:fail? + (lambda (_) #f)]) + (extract-binding/single sym bindings)))] + [flush (maybe-get 'flush)]) + (cond + [flush + (doc-collections-changed) + `(html (head (title "Flush")) + (body (h2 "Flushed documentation cache")))] + [else + (let ([search-string (maybe-get 'search-string)] + [search-type (maybe-get 'search-type)] + [match-type (maybe-get 'match-type)] + [manuals (maybe-get 'manuals)] + [doc.txt (maybe-get 'doctxt)] + [lang-name (maybe-get 'langname)]) + (if (or (not search-string) (= (string-length search-string) 0)) + empty-search-page + (search-results (lucky-search? bindings) + search-string + (or search-type "keyword-index") + (or match-type "containing-match") + (convert-manuals manuals) + (cond [(not doc.txt) #t] + [(equal? doc.txt "false") #f] + [else #t]) + lang-name)))]))))))) diff --git a/collects/help/servlets/scheme/doc.ss b/collects/help/servlets/scheme/doc.ss index 87c401407e..2a2b1effa0 100644 --- a/collects/help/servlets/scheme/doc.ss +++ b/collects/help/servlets/scheme/doc.ss @@ -8,7 +8,9 @@ (define (start initial-request) (define (make-header-text s) (color-highlight `(h2 () ,s))) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "Documentation")) (body @@ -41,4 +43,4 @@ (a ([href "/servlets/howtouse.ss#search"]) "Searching") " in Help Desk finds documenation from all sources, including " (a ([href "/servlets/howtodrscheme.ss"]) "DrScheme") - " and the language and library documentation.")))) + " and the language and library documentation.")))))) \ No newline at end of file diff --git a/collects/help/servlets/scheme/how.ss b/collects/help/servlets/scheme/how.ss index 8459736c37..9adb3289e5 100644 --- a/collects/help/servlets/scheme/how.ss +++ b/collects/help/servlets/scheme/how.ss @@ -10,7 +10,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () (send/finish `(html (head ,hd-css ,@hd-links (title "Software & Components")) @@ -112,4 +114,4 @@ (a ((name "installed-components"))) (i "The list below was generated by searching the set of installed" " libraries.") - (ul ,@(help-desk:installed-components))))))) + (ul ,@(help-desk:installed-components))))))))) \ No newline at end of file diff --git a/collects/help/servlets/scheme/langlevels.ss b/collects/help/servlets/scheme/langlevels.ss index 2d324bae81..7a75a7d5b8 100644 --- a/collects/help/servlets/scheme/langlevels.ss +++ b/collects/help/servlets/scheme/langlevels.ss @@ -6,7 +6,9 @@ (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) + (with-errors-to-browser + send/finish + (lambda () `(html (head ,hd-css ,@hd-links (title "A Note on Language Levels")) (body @@ -57,4 +59,4 @@ "Please follow the links on this page for more information. If you" " have additional questions or comments, please contact us at " (a ((href "mailto:scheme@plt-scheme.org")) "scheme@plt-scheme.org") - ".")))) + ".")))))) \ No newline at end of file diff --git a/collects/help/servlets/scheme/misc.ss b/collects/help/servlets/scheme/misc.ss index 44bae978be..10af1a210b 100644 --- a/collects/help/servlets/scheme/misc.ss +++ b/collects/help/servlets/scheme/misc.ss @@ -8,7 +8,7 @@ [txt (cadr url/txt)]) `(li (b (a ([href ,(string-append "/servlets/scheme/misc/" url)]) ,txt))))) - + (define links '(("standalone.ss" "How to build a stand-alone executable") ("graphics.ss" "How to write graphics programs") @@ -18,19 +18,21 @@ ("activex.ss" "How to use ActiveX components") ("database.ss" "How to connect to databases") ("system.ss" "How to call low-level system routines"))) - + (provide interface-version timeout start) (define interface-version 'v1) (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - `(html (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme")) - (body - (h1 "How to do things in Scheme") - (ul ,@(map make-link-line links)) - (p) - "If you did't find what you're looking for in the list above, try " - (a ((href "/servlets/howtouse.ss#search")) "searching") - " in Help Desk. Also, check " - (a ((href "http://www.htus.org/")) (i "How to Use Scheme")) - ".")))) + (with-errors-to-browser + send/finish + (lambda () + `(html (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme")) + (body + (h1 "How to do things in Scheme") + (ul ,@(map make-link-line links)) + (p) + "If you did't find what you're looking for in the list above, try " + (a ((href "/servlets/howtouse.ss#search")) "searching") + " in Help Desk. Also, check " + (a ((href "http://www.htus.org/")) (i "How to Use Scheme")) + ".")))))) \ No newline at end of file diff --git a/collects/help/servlets/scheme/misc/activex.ss b/collects/help/servlets/scheme/misc/activex.ss index 9404deaa69..b27a16d24a 100644 --- a/collects/help/servlets/scheme/misc/activex.ss +++ b/collects/help/servlets/scheme/misc/activex.ss @@ -8,8 +8,9 @@ (define timeout +inf.0) (define (start initial-request) - (report-errors-to-browser send/finish) - + (with-errors-to-browser + send/finish + (lambda () `(HTML (HEAD ,hd-css ,@hd-links @@ -26,4 +27,4 @@ (TARGET "_top")) "http://www.plt-scheme.org/software/mysterx/")) (P) ,(collection-doc-link "mysterx" - "The MysterX collection"))))) \ No newline at end of file + "The MysterX collection"))))))) \ No newline at end of file diff --git a/collects/help/servlets/scheme/misc/batch.ss b/collects/help/servlets/scheme/misc/batch.ss index a4a8a3dc37..87189a5fab 100644 --- a/collects/help/servlets/scheme/misc/batch.ss +++ b/collects/help/servlets/scheme/misc/batch.ss @@ -8,9 +8,9 @@ (define timeout +inf.0) (define (start initial-request) - - (report-errors-to-browser send/finish) - + (with-errors-to-browser + send/finish + (lambda () `(HTML (HEAD ,hd-css ,@hd-links @@ -49,4 +49,4 @@ "lines beginning with semicolons as comments, and runs the " "Scheme code. When the Scheme program is " "done, control returns to the batch file, and the " - (TT "goto") " jumps around the Scheme code.")))) \ No newline at end of file + (TT "goto") " jumps around the Scheme code.")))))) \ No newline at end of file diff --git a/collects/help/servlets/scheme/misc/cgi.ss b/collects/help/servlets/scheme/misc/cgi.ss index eb6417f2b0..9fd17e5d0a 100644 --- a/collects/help/servlets/scheme/misc/cgi.ss +++ b/collects/help/servlets/scheme/misc/cgi.ss @@ -7,147 +7,147 @@ (define timeout +inf.0) (define (start initial-request) - - (report-errors-to-browser send/finish) - - `(HTML - (HEAD ,hd-css - ,@hd-links - (TITLE "How to write CGI scripts")) - (BODY - (H1 "How to write CGI scripts") - (A ((NAME "cgi") (VALUE "CGI scripts"))) - "Type " (TT "CGI") " in the " (B "Search for") " " - "field in Help Desk and click on the " - (B (TT "Search")) " button to get information " - "on CGI-related functions." - (P) - "A CGI script is merely a program with funny inputs and " - "outputs. Input comes either from an environment variable " - "or through the standard input port, in a special format. " - "Output consists of a MIME header followed by the content. " - "Everything in-between is pure program." - (P) - "MzScheme comes with a CGI library that is designed to " - "make it easy to write such scripts. In the mini-tutorial " - "below, we'll walk you through the " - "construction of such a script. If you have questions or " - "comments, send email to " - (A ((HREF "mailto:sk@plt-scheme.org")) - "sk@plt-scheme.org") "." + (with-errors-to-browser + send/finish + (lambda () + `(HTML + (HEAD ,hd-css + ,@hd-links + (TITLE "How to write CGI scripts")) + (BODY + (H1 "How to write CGI scripts") + (A ((NAME "cgi") (VALUE "CGI scripts"))) + "Type " (TT "CGI") " in the " (B "Search for") " " + "field in Help Desk and click on the " + (B (TT "Search")) " button to get information " + "on CGI-related functions." (P) - (HR) + "A CGI script is merely a program with funny inputs and " + "outputs. Input comes either from an environment variable " + "or through the standard input port, in a special format. " + "Output consists of a MIME header followed by the content. " + "Everything in-between is pure program." (P) - "Let's write a simple \"finger server\" in MzScheme. " - "The front-end will be a Web form that accepts a username. " - "The form should supply a username in the field `name'. " - "The CGI script fingers that user." - (P) - "First, make sure you have MzScheme installed on the host " - "where your Web server is located." - (P) - "A CGI script must be an executable. Each OS has different " - "ways of launching an application. Under Unix, it's " - "probably easiest to make them simple shell scripts. " - "Therefore, place the following magic incantation at the " - "top of your script:" - (P) - (PRE - " #!/bin/sh" (BR) - " string=? ; exec /usr/local/bin/mzscheme -r $0 \"$@\"") - (P) - "Make sure the path to MzScheme is specified correctly." - (P) - "Now we're in Scheme-land. First, let's load the Scheme " - "CGI library and define where `finger' resides." - (P) - (PRE - " (require (lib \"cgi.ss\" \"net\"))" (BR) - " (define finger-program \"/usr/bin/finger\")") - (P) - "Next we must get the names bound by the form, and " - "extract the username field." - (P) - (PRE - " (let ((bindings (get-bindings)))" (BR) - " (let ((name (extract-binding/single 'name bindings)))") - (P) - "We use extract-binding/single to make sure only one name " - "field was bound. (You can bind the same field multiple " - "times using check-boxes. This is just one kind of " - "error-checking; a robust CGI script will do more." - (P) - "Next we invoke the finger program using `process*'. " - "If no username was specified, we just run finger on the host." - (P) - (PRE - " (let ((results (if (string=? name \"\"))" (BR) - " (process* finger-program)" (BR) - " (process* finger-program name))))") - (P) - "The `process*' function returns a list of several values. " - "The first of these is the output port. Let's pull this " - "out and name it." - (P) - (PRE - " (let ((proc->self (car results)))") - (P) - "Now we extract the output of running finger into a " - "list of strings." - (P) - (PRE - " (let ((strings (let loop " (BR) - " (let ((l (read-line proc->self)))" (BR) - " (if (eof-object? l)" (BR) - " null" (BR) - " (cons l (loop))))))))") - (P) - "All that's left is to print this out to the user. " - "We use the `generate-html-output' procedure to do that, " - "which takes care of generating the appropriate MIME header " - "(as required of CGI scripts). " - "Note that the 
 tag of HTML doesn't prevent its "
-          "contents from being processed.  To avoid this "
-          "(i.e., to generate truly verbatim output), "
-          "we use `string->html', which knows about HTML quoting "
-          "conventions."
-          (P)
-          (PRE 
-           " (generate-html-output \"Finger Gateway Output\"" (BR)
-           "   (append " (BR)
-           "    '(\"
\")" (BR)
-           "    (map string->html strings)" (BR)
-           "    '(\"
\"))))))))")
-          (P)
-          "That's all!  This program will work irrespective of "
-          "whether the form uses a GET or POST method to send its "
-          "data over, which gives designers additional flexibility "
-          "(GET provides a weak form of persistence, while "
-          "POST is more robust and better suited to large volumes of "
-          "data)."
-          (P)
-          "Here's the entire program, once again:"
-          (P)
-          (PRE 
-           " #!/bin/sh" (BR)
-           " string=? ; exec /usr/local/bin/mzscheme -r $0 "$@"" (BR)
-           "" (BR)
-           " (require (lib \"cgi.ss\" \"net\"))" (BR)
-           " (define finger-program \"/usr/bin/finger\")" (BR)
-           ""  (BR)
-           " (let ((bindings (get-bindings)))" (BR)
-           "   (let ((name (extract-binding/single 'name bindings)))" (BR)
-           "    (let ((results (if (string=? name "")" (BR)
-           "      (process* finger-program)" (BR)
-           "     (process* finger-program name))))" (BR)
-           "     (let ((proc->self (car results)))" (BR)
-           "       (let ((strings (let loop " (BR)
-           "                        (let ((l (read-line proc->self)))" (BR)
-           "                          (if (eof-object? l)" (BR)
-           "                            null" (BR)
-           "                            (cons l (loop)))))))" (BR)
-           "         (generate-html-output \"Finger Gateway Output\"" (BR)
-           "         (append" (BR)
-           "           '(\"
\")" (BR)
-           "           (map string->html strings)" (BR)
-           "           '(\"
\"))))))))")))))
\ No newline at end of file
+          "MzScheme comes with a CGI library that is designed to "
+          "make it easy to write such scripts.  In the mini-tutorial "
+          "below, we'll walk you through the "
+          "construction of such a script.  If you have questions or "
+          "comments, send email to "
+          (A ((HREF "mailto:sk@plt-scheme.org"))
+             "sk@plt-scheme.org") "."
+                                  (P)
+                                  (HR)
+                                  (P)
+                                  "Let's write a simple \"finger server\" in MzScheme. "
+                                  "The front-end will be a Web form that accepts a username. "
+                                  "The form should supply a username in the field `name'. "
+                                  "The CGI script fingers that user."
+                                  (P)
+                                  "First, make sure you have MzScheme installed on the host "
+                                  "where your Web server is located."
+                                  (P)
+                                  "A CGI script must be an executable.  Each OS has different "
+                                  "ways of launching an application.  Under Unix, it's "
+                                  "probably easiest to make them simple shell scripts.  "
+                                  "Therefore, place the following magic incantation at the "
+                                  "top of your script:"
+                                  (P)
+                                  (PRE 
+                                   " #!/bin/sh" (BR)
+                                   " string=? ; exec /usr/local/bin/mzscheme -r $0 \"$@\"")
+                                  (P)
+                                  "Make sure the path to MzScheme is specified correctly."
+                                  (P)
+                                  "Now we're in Scheme-land.  First, let's load the Scheme "
+                                  "CGI library and define where `finger' resides."
+                                  (P)
+                                  (PRE 
+                                   " (require (lib \"cgi.ss\" \"net\"))" (BR)
+                                   " (define finger-program \"/usr/bin/finger\")")
+                                  (P)
+                                  "Next we must get the names bound by the form, and "
+                                  "extract the username field."
+                                  (P)
+                                  (PRE 
+                                   " (let ((bindings (get-bindings)))" (BR)
+                                   "   (let ((name (extract-binding/single 'name bindings)))")
+                                  (P)
+                                  "We use extract-binding/single to make sure only one name "
+                                  "field was bound.  (You can bind the same field multiple "
+                                  "times using check-boxes.  This is just one kind of "
+                                  "error-checking; a robust CGI script will do more."
+                                  (P)
+                                  "Next we invoke the finger program using `process*'.  "
+                                  "If no username was specified, we just run finger on the host."
+                                  (P)
+                                  (PRE 
+                                   " (let ((results (if (string=? name \"\"))" (BR)
+                                   "   (process* finger-program)" (BR)
+                                   "   (process* finger-program name))))")
+                                  (P)
+                                  "The `process*' function returns a list of several values. "
+                                  "The first of these is the output port.  Let's pull this "
+                                  "out and name it."
+                                  (P)
+                                  (PRE 
+                                   " (let ((proc->self (car results)))")
+                                  (P)
+                                  "Now we extract the output of running finger into a "
+                                  "list of strings."
+                                  (P)
+                                  (PRE 
+                                   " (let ((strings (let loop " (BR)
+                                   "   (let ((l (read-line proc->self)))" (BR)
+                                   "     (if (eof-object? l)" (BR)
+                                   "        null" (BR)
+                                   "        (cons l (loop))))))))")
+                                  (P)
+                                  "All that's left is to print this out to the user.  "
+                                  "We use the `generate-html-output' procedure to do that, "
+                                  "which takes care of generating the appropriate MIME header "
+                                  "(as required of CGI scripts). "
+                                  "Note that the 
 tag of HTML doesn't prevent its "
+                                  "contents from being processed.  To avoid this "
+                                  "(i.e., to generate truly verbatim output), "
+                                  "we use `string->html', which knows about HTML quoting "
+                                  "conventions."
+                                  (P)
+                                  (PRE 
+                                   " (generate-html-output \"Finger Gateway Output\"" (BR)
+                                   "   (append " (BR)
+                                   "    '(\"
\")" (BR)
+                                   "    (map string->html strings)" (BR)
+                                   "    '(\"
\"))))))))")
+                                  (P)
+                                  "That's all!  This program will work irrespective of "
+                                  "whether the form uses a GET or POST method to send its "
+                                  "data over, which gives designers additional flexibility "
+                                  "(GET provides a weak form of persistence, while "
+                                  "POST is more robust and better suited to large volumes of "
+                                  "data)."
+                                  (P)
+                                  "Here's the entire program, once again:"
+                                  (P)
+                                  (PRE 
+                                   " #!/bin/sh" (BR)
+                                   " string=? ; exec /usr/local/bin/mzscheme -r $0 "$@"" (BR)
+                                   "" (BR)
+                                   " (require (lib \"cgi.ss\" \"net\"))" (BR)
+                                   " (define finger-program \"/usr/bin/finger\")" (BR)
+                                   ""  (BR)
+                                   " (let ((bindings (get-bindings)))" (BR)
+                                   "   (let ((name (extract-binding/single 'name bindings)))" (BR)
+                                   "    (let ((results (if (string=? name "")" (BR)
+                                   "      (process* finger-program)" (BR)
+                                   "     (process* finger-program name))))" (BR)
+                                   "     (let ((proc->self (car results)))" (BR)
+                                   "       (let ((strings (let loop " (BR)
+                                   "                        (let ((l (read-line proc->self)))" (BR)
+                                   "                          (if (eof-object? l)" (BR)
+                                   "                            null" (BR)
+                                   "                            (cons l (loop)))))))" (BR)
+                                   "         (generate-html-output \"Finger Gateway Output\"" (BR)
+                                   "         (append" (BR)
+                                   "           '(\"
\")" (BR)
+                                   "           (map string->html strings)" (BR)
+                                   "           '(\"
\"))))))))")))))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/database.ss b/collects/help/servlets/scheme/misc/database.ss
index ebc51029df..43c961d222 100644
--- a/collects/help/servlets/scheme/misc/database.ss
+++ b/collects/help/servlets/scheme/misc/database.ss
@@ -8,27 +8,28 @@
   (define timeout +inf.0)
   
   (define (start initial-request)
-    (report-errors-to-browser send/finish)
-    
-    `(HTML 
-      (HEAD ,hd-css
-            ,@hd-links
-            (TITLE "How to connect to databases"))
-      (BODY 
-       (H1  "How to connect to databases") 
-       (A ((NAME "db") (VALUE "Database connections")))
-       "SrPersist (\"Sister Persist\") is an ODBC interface for "
-       "DrScheme and MzScheme. "
-       "Download SrPersist from "
-       (PRE  
-        " " 
-        (A ((HREF "http://www.plt-scheme.org/software/srpersist/")
-            (TARGET "_top")) "http://www.plt-scheme.org/software/srpersist/") ". ")
-       "ODBC is a very low-level interface. "
-       "Francisco Solsona has built a higher-level interface, "
-       "SchemeQL, that uses SrPersist.  See "
-       (PRE 
-        " " 
-        (A ((HREF "http://schematics.sourceforge.net/schemeql.html")
-            (TARGET "_top")) "http://schematics.sourceforge.net/schemeql.html"))
-       " for more details."))))
\ No newline at end of file
+    (with-errors-to-browser 
+     send/finish
+     (lambda ()
+       `(HTML 
+         (HEAD ,hd-css
+               ,@hd-links
+               (TITLE "How to connect to databases"))
+         (BODY 
+          (H1  "How to connect to databases") 
+          (A ((NAME "db") (VALUE "Database connections")))
+          "SrPersist (\"Sister Persist\") is an ODBC interface for "
+          "DrScheme and MzScheme. "
+          "Download SrPersist from "
+          (PRE  
+           " " 
+           (A ((HREF "http://www.plt-scheme.org/software/srpersist/")
+               (TARGET "_top")) "http://www.plt-scheme.org/software/srpersist/") ". ")
+          "ODBC is a very low-level interface. "
+          "Francisco Solsona has built a higher-level interface, "
+          "SchemeQL, that uses SrPersist.  See "
+          (PRE 
+           " " 
+           (A ((HREF "http://schematics.sourceforge.net/schemeql.html")
+               (TARGET "_top")) "http://schematics.sourceforge.net/schemeql.html"))
+          " for more details."))))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/graphics.ss b/collects/help/servlets/scheme/misc/graphics.ss
index c0e833c0bc..7bbfbfa318 100644
--- a/collects/help/servlets/scheme/misc/graphics.ss
+++ b/collects/help/servlets/scheme/misc/graphics.ss
@@ -9,27 +9,27 @@
   (define timeout +inf.0)
   
   (define (start initial-request)
-    
-    (report-errors-to-browser send/finish)
-    
-    `(HTML 
-      (HEAD ,hd-css
-            ,@hd-links
-            (TITLE "How to write graphics programs"))
-      (BODY 
-       (H1 "How to write graphics programs")
-       (A ((NAME "gfx") (VALUE "Graphics")))
-       (A ((NAME "gui") (VALUE "GUIs")))
-       (A ((NAME "gui2") (VALUE "Graphical User Interfaces")))
-       "To write graphics programs, use DrScheme with the "
-       "Graphical (MrEd) flavor of the PLT " 
-       (A ((HREF "/servlets/scheme/what.ss")) " language") ". "
-       "MrEd provides a complete GUI toolbox that is described "
-       "in " 
-       ,(main-manual-page "mred") ". "
-       (P)
-       "For simple graphics programs, you may also use the "
-       "viewport-based graphics library, which is described in "
-       ,(manual-entry "misclib" "viewport" "Viewport Graphics") ". "
-       "The following declaration loads viewport graphics into MrEd:"
-       (PRE " (require (lib \"graphics.ss\" \"graphics\"))")))))
\ No newline at end of file
+    (with-errors-to-browser 
+     send/finish
+     (lambda ()
+       `(HTML 
+         (HEAD ,hd-css
+               ,@hd-links
+               (TITLE "How to write graphics programs"))
+         (BODY 
+          (H1 "How to write graphics programs")
+          (A ((NAME "gfx") (VALUE "Graphics")))
+          (A ((NAME "gui") (VALUE "GUIs")))
+          (A ((NAME "gui2") (VALUE "Graphical User Interfaces")))
+          "To write graphics programs, use DrScheme with the "
+          "Graphical (MrEd) flavor of the PLT " 
+          (A ((HREF "/servlets/scheme/what.ss")) " language") ". "
+          "MrEd provides a complete GUI toolbox that is described "
+          "in " 
+          ,(main-manual-page "mred") ". "
+          (P)
+          "For simple graphics programs, you may also use the "
+          "viewport-based graphics library, which is described in "
+          ,(manual-entry "misclib" "viewport" "Viewport Graphics") ". "
+          "The following declaration loads viewport graphics into MrEd:"
+          (PRE " (require (lib \"graphics.ss\" \"graphics\"))")))))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/script.ss b/collects/help/servlets/scheme/misc/script.ss
index ffb20aedc4..007d883de5 100644
--- a/collects/help/servlets/scheme/misc/script.ss
+++ b/collects/help/servlets/scheme/misc/script.ss
@@ -8,42 +8,42 @@
   (define timeout +inf.0)
   
   (define (start initial-request)
-    
-    (report-errors-to-browser send/finish)
-    
-    `(HTML 
-      (HEAD ,hd-css
-            ,@hd-links
-            (TITLE "How to write Unix shell scripts"))  
-      (BODY 
-       (H1 "How to write Unix shell scripts")  
-       (A ((NAME "sh") (VALUE "Shell scripts")))
-       "When MzScheme is installed as part of the standard Unix "
-       "PLT distribution, " 
-       (TT "plt/bin/mzscheme") " and  " 
-       (TT "plt/bin/mred") " are binary executables." 
-       (P) 
-       "Thus, they can be used with Unix's " (TT  "#!") 
-       " convention as follows:"
-       (PRE  
-        "  #! /usr/local/lib/plt/bin/mzscheme -r  ... " (BR) 
-        " " (I  "scheme-program") " ...")
-       "assuming that the " (TT  "plt") " tree is installed as " 
-       (TT "/usr/local/lib/plt") ". "
-       "To avoid specifying an absolute path, use " 
-       (TT "/usr/bin/env") ":"
-       (PRE  
-        " #! /usr/bin/env mzscheme -r  ... " (BR)
-        " " (I  "scheme-program") " ...")
-       (P)
-       "The above works when " 
-       (TT  "mzscheme") 
-       " is in the user's path. "
-       "The " (TT "mred") " executable can be used in the "
-       "same way for GUI scripts."
-       (P)
-       "Within " (I "scheme-program") ", " 
-       (TT  "(current-command-line-arguments)") 
-       " produces a vector of strings for the arguments "
-       "passed to the script. The vector is also available as " 
-       (TT "argv") "."))))
\ No newline at end of file
+    (with-errors-to-browser 
+     send/finish
+     (lambda ()
+       `(HTML 
+         (HEAD ,hd-css
+               ,@hd-links
+               (TITLE "How to write Unix shell scripts"))  
+         (BODY 
+          (H1 "How to write Unix shell scripts")  
+          (A ((NAME "sh") (VALUE "Shell scripts")))
+          "When MzScheme is installed as part of the standard Unix "
+          "PLT distribution, " 
+          (TT "plt/bin/mzscheme") " and  " 
+          (TT "plt/bin/mred") " are binary executables." 
+          (P) 
+          "Thus, they can be used with Unix's " (TT  "#!") 
+          " convention as follows:"
+          (PRE  
+           "  #! /usr/local/lib/plt/bin/mzscheme -r  ... " (BR) 
+           " " (I  "scheme-program") " ...")
+          "assuming that the " (TT  "plt") " tree is installed as " 
+          (TT "/usr/local/lib/plt") ". "
+          "To avoid specifying an absolute path, use " 
+          (TT "/usr/bin/env") ":"
+          (PRE  
+           " #! /usr/bin/env mzscheme -r  ... " (BR)
+           " " (I  "scheme-program") " ...")
+          (P)
+          "The above works when " 
+          (TT  "mzscheme") 
+          " is in the user's path. "
+          "The " (TT "mred") " executable can be used in the "
+          "same way for GUI scripts."
+          (P)
+          "Within " (I "scheme-program") ", " 
+          (TT  "(current-command-line-arguments)") 
+          " produces a vector of strings for the arguments "
+          "passed to the script. The vector is also available as " 
+          (TT "argv") "."))))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/standalone.ss b/collects/help/servlets/scheme/misc/standalone.ss
index 70251662ad..3878fda624 100644
--- a/collects/help/servlets/scheme/misc/standalone.ss
+++ b/collects/help/servlets/scheme/misc/standalone.ss
@@ -9,26 +9,26 @@
   (define timeout +inf.0)
   
   (define (start initial-request)
-    
-    (report-errors-to-browser send/finish)
-    
-    `(HTML 
-      (HEAD ,hd-css
-            ,@hd-links
-            (TITLE "How to build a stand-alone executable"))
-      (BODY 
-       (H1 "How to build a stand-alone executable")
-       (A ((NAME "exec") (VALUE "Standalone executables")))
-       (A ((name "exec2") (VALUE "Stand-alone executables")))
-       "To create stand-alone executables, use DrScheme's "
-       (tt "Scheme | Create Executable ...")
-       " menu item. This menu is sensitive to the language levels; "
-       "the " (tt "module") " language permits the most flexibility "
-       "in creating executables."
-       
-       (p)
-       "The mzc compiler provides a more low-level interface "
-       "to stand-alone executables creation. "
-       "See " 
-       ,(main-manual-page "mzc")
-       " for more information."))))
\ No newline at end of file
+    (with-errors-to-browser 
+     send/finish
+     (lambda ()
+       `(HTML 
+         (HEAD ,hd-css
+               ,@hd-links
+               (TITLE "How to build a stand-alone executable"))
+         (BODY 
+          (H1 "How to build a stand-alone executable")
+          (A ((NAME "exec") (VALUE "Standalone executables")))
+          (A ((name "exec2") (VALUE "Stand-alone executables")))
+          "To create stand-alone executables, use DrScheme's "
+          (tt "Scheme | Create Executable ...")
+          " menu item. This menu is sensitive to the language levels; "
+          "the " (tt "module") " language permits the most flexibility "
+          "in creating executables."
+          
+          (p)
+          "The mzc compiler provides a more low-level interface "
+          "to stand-alone executables creation. "
+          "See " 
+          ,(main-manual-page "mzc")
+          " for more information."))))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/misc/system.ss b/collects/help/servlets/scheme/misc/system.ss
index b15230c445..43733563f0 100644
--- a/collects/help/servlets/scheme/misc/system.ss
+++ b/collects/help/servlets/scheme/misc/system.ss
@@ -9,18 +9,18 @@
   (define timeout +inf.0)
   
   (define (start initial-request)
-    
-    (report-errors-to-browser send/finish)
-    
-    `(HTML
-      (HEAD ,hd-css
-            ,@hd-links
-            (TITLE "How to call low-level system routines")) 
-      (BODY
-       (H1 "How to call low-level system routines") 
-       (A ((NAME "os") (VALUE "Low-level operating system calls")))
-       "To call low-level system routines, you must write "
-       "an extension to MzScheme using the C programming language. "
-       "See " 
-       ,(main-manual-page "insidemz")
-       " for details."))))
\ No newline at end of file
+    (with-errors-to-browser 
+     send/finish
+     (lambda ()
+       `(HTML
+         (HEAD ,hd-css
+               ,@hd-links
+               (TITLE "How to call low-level system routines")) 
+         (BODY
+          (H1 "How to call low-level system routines") 
+          (A ((NAME "os") (VALUE "Low-level operating system calls")))
+          "To call low-level system routines, you must write "
+          "an extension to MzScheme using the C programming language. "
+          "See " 
+          ,(main-manual-page "insidemz")
+          " for details."))))))
\ No newline at end of file
diff --git a/collects/help/servlets/scheme/what.ss b/collects/help/servlets/scheme/what.ss
index b6f73255c3..5be774f6e6 100644
--- a/collects/help/servlets/scheme/what.ss
+++ b/collects/help/servlets/scheme/what.ss
@@ -9,95 +9,97 @@
   (define (standout-text s)
     (with-color "forestgreen" `(B ,s)))
   (define (start initial-request)
-    (report-errors-to-browser send/finish)
-    `(html
-      (head ,hd-css ,@hd-links (title "Scheme Languages"))
-      (body
-       (h1 "Scheme Languages")
-       (a ([name "scheme"] [value "Language Family"]))
-       (a ([name "r5rs"] [value "r5rs"]))
-       (a ([name "language levels"] [value "language levels"]))
-       "From the introduction of " ,(main-manual-page "r5rs") " (R5RS):"
-       (p)
-       (dl (dd "Scheme is a statically scoped and properly tail-recursive"
-               " dialect of the Lisp programming language [...] designed to"
-               " have an exceptionally clear and simple semantics and few"
-               " different ways to form expressions.  A wide variety of"
-               " programming paradigms, including imperative, functional, and"
-               " message passing styles, find convenient expression in"
-               " Scheme."))
-       (p)
-       "DrScheme supports many dialects of Scheme.  The following dialects are"
-       " specifically designed for teaching computer science.  In DrScheme's "
-       (a ([href "/servlets/scheme/what.ss#lang-sel"])
-          "language selection menu")
-       ", they are found under the heading " (b "How to Design Programs") "."
-       (ul (li (a ([name "beg"] [value "Beginning Student language"]))
-               ,(standout-text "Beginning Student")
-               " is a pedagogical version of Scheme that is tailored for"
-               " beginning computer science students.")
-           (li (a ([name "begla"]
-                   [value "Beginning Student with List Abbreviations language"]))
-               ,(standout-text "Beginning Student with List Abbreviations")
-               " extends Beginning Student with convenient (but potentially"
-               " confusing) ways to write lists, including quasiquote.")
-           (li (a ([name "int"] [value "Intermediate Student language"]))
-               ,(standout-text "Intermediate Student")
-               " adds local bindings and higher-order functions.")
-           (li (a ([name "intlam"]
-                   [value "Intermediate Student with Lambda language"]))
-               ,(standout-text "Intermediate Student with Lambda")
-               " adds anonymous functions.")
-           (li (a ([name "adv"] [value "Advanced Student language"]))
-               ,(standout-text "Advanced Student")
-               " adds mutable state."))
-       "The "
-       ,(standout-text "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 "
-       (a ([name "r5rs2"] [value "R5RS Scheme language"]))
-       ,(standout-text "R5RS")
-       " language is a standard dialect of Scheme that is defined by the "
-       ,(main-manual-page "r5rs") ". "
-       (a ([name "full"] [value "PLT Scheme language"]))
-       "In DrScheme's "
-       (a ([href "/servlets/scheme/what.ss#lang-sel"])
-          "language selection menu")
-       ", the following languages are found under the heading " (b "PLT") ":"
-       (ul (li ,(standout-text "Textual (MzScheme)") " is a superset of R5RS"
-               " Scheme.  In addition to the 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 " ,(main-manual-page "mzscheme") ". ")
-           (li ,(standout-text "Graphical (MrEd)") " includes the "
-               (standout-text "Textual (MzScheme)") " language and adds a"
-               " graphical toolbox, described in "
-               ,(main-manual-page "mred") ".")
-           (li ,(standout-text "Pretty Big") " is a superset of the "
-               (standout-text "Graphical (MrEd)")
-               " language, and adds forms from the "
-               (standout-text "Pretty Big") " language.  For those forms that"
-               " are in both languages, Pretty Big behaves like Graphical"
-               " (MrEd)."))
-       "The " (a ([name "module"] [value "module"]))
-       ,(standout-text "(module ...)")
-       " language supports development using PLT Scheme's "
-       ,(manual-entry "mzscheme" "modules" `(code "module"))
-       " form, where the module's language is explicitly declared in the code."
-       (p)
-       "See " ,(manual-entry "drscheme" "language levels" "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 "
-       (a ([href "/servlets/manuals.ss"]) "manuals page") "."
-       (p)
-       (a ([name "lang-sel"] [value "language, setting"]))
-       "To change the"
-       " language, select the " (b "Choose Language...") " item in the "
-       (B "Language") " menu."))))
+    (with-errors-to-browser 
+     send/finish
+     (lambda ()
+       `(html
+         (head ,hd-css ,@hd-links (title "Scheme Languages"))
+         (body
+          (h1 "Scheme Languages")
+          (a ([name "scheme"] [value "Language Family"]))
+          (a ([name "r5rs"] [value "r5rs"]))
+          (a ([name "language levels"] [value "language levels"]))
+          "From the introduction of " ,(main-manual-page "r5rs") " (R5RS):"
+          (p)
+          (dl (dd "Scheme is a statically scoped and properly tail-recursive"
+                  " dialect of the Lisp programming language [...] designed to"
+                  " have an exceptionally clear and simple semantics and few"
+                  " different ways to form expressions.  A wide variety of"
+                  " programming paradigms, including imperative, functional, and"
+                  " message passing styles, find convenient expression in"
+                  " Scheme."))
+          (p)
+          "DrScheme supports many dialects of Scheme.  The following dialects are"
+          " specifically designed for teaching computer science.  In DrScheme's "
+          (a ([href "/servlets/scheme/what.ss#lang-sel"])
+             "language selection menu")
+          ", they are found under the heading " (b "How to Design Programs") "."
+          (ul (li (a ([name "beg"] [value "Beginning Student language"]))
+                  ,(standout-text "Beginning Student")
+                  " is a pedagogical version of Scheme that is tailored for"
+                  " beginning computer science students.")
+              (li (a ([name "begla"]
+                      [value "Beginning Student with List Abbreviations language"]))
+                  ,(standout-text "Beginning Student with List Abbreviations")
+                  " extends Beginning Student with convenient (but potentially"
+                  " confusing) ways to write lists, including quasiquote.")
+              (li (a ([name "int"] [value "Intermediate Student language"]))
+                  ,(standout-text "Intermediate Student")
+                  " adds local bindings and higher-order functions.")
+              (li (a ([name "intlam"]
+                      [value "Intermediate Student with Lambda language"]))
+                  ,(standout-text "Intermediate Student with Lambda")
+                  " adds anonymous functions.")
+              (li (a ([name "adv"] [value "Advanced Student language"]))
+                  ,(standout-text "Advanced Student")
+                  " adds mutable state."))
+          "The "
+          ,(standout-text "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 "
+          (a ([name "r5rs2"] [value "R5RS Scheme language"]))
+          ,(standout-text "R5RS")
+          " language is a standard dialect of Scheme that is defined by the "
+          ,(main-manual-page "r5rs") ". "
+          (a ([name "full"] [value "PLT Scheme language"]))
+          "In DrScheme's "
+          (a ([href "/servlets/scheme/what.ss#lang-sel"])
+             "language selection menu")
+          ", the following languages are found under the heading " (b "PLT") ":"
+          (ul (li ,(standout-text "Textual (MzScheme)") " is a superset of R5RS"
+                  " Scheme.  In addition to the 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 " ,(main-manual-page "mzscheme") ". ")
+              (li ,(standout-text "Graphical (MrEd)") " includes the "
+                  (standout-text "Textual (MzScheme)") " language and adds a"
+                  " graphical toolbox, described in "
+                  ,(main-manual-page "mred") ".")
+              (li ,(standout-text "Pretty Big") " is a superset of the "
+                  (standout-text "Graphical (MrEd)")
+                  " language, and adds forms from the "
+                  (standout-text "Pretty Big") " language.  For those forms that"
+                  " are in both languages, Pretty Big behaves like Graphical"
+                  " (MrEd)."))
+          "The " (a ([name "module"] [value "module"]))
+          ,(standout-text "(module ...)")
+          " language supports development using PLT Scheme's "
+          ,(manual-entry "mzscheme" "modules" `(code "module"))
+          " form, where the module's language is explicitly declared in the code."
+          (p)
+          "See " ,(manual-entry "drscheme" "language levels" "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 "
+          (a ([href "/servlets/manuals.ss"]) "manuals page") "."
+          (p)
+          (a ([name "lang-sel"] [value "language, setting"]))
+          "To change the"
+          " language, select the " (b "Choose Language...") " item in the "
+          (B "Language") " menu."))))))
\ No newline at end of file
diff --git a/collects/help/servlets/teachpacks.ss b/collects/help/servlets/teachpacks.ss
index 5bcd370961..009ca37911 100644
--- a/collects/help/servlets/teachpacks.ss
+++ b/collects/help/servlets/teachpacks.ss
@@ -7,11 +7,13 @@
   (define interface-version 'v1)
   (define timeout +inf.0)
   (define (start initial-request)
-    (report-errors-to-browser send/finish)
-    `(html
-      (head (title "Teachpacks"))
-      (body (h1 "Teachpacks")
-            (ul (li (b (a ([href ,(get-manual-index "teachpack")])
-                          "Teachpacks for \"How to Design Programs\"")))
-                (li (b (a ([href ,(get-manual-index "teachpack-htdc")])
-                          "Teachpacks for \"How to Design Classes\""))))))))
+    (with-errors-to-browser 
+     send/finish
+     (lambda ()
+       `(html
+         (head (title "Teachpacks"))
+         (body (h1 "Teachpacks")
+               (ul (li (b (a ([href ,(get-manual-index "teachpack")])
+                             "Teachpacks for \"How to Design Programs\"")))
+                   (li (b (a ([href ,(get-manual-index "teachpack-htdc")])
+                             "Teachpacks for \"How to Design Classes\""))))))))))
\ No newline at end of file
diff --git a/collects/htdp/servlet.ss b/collects/htdp/servlet.ss
index 187ff30d5b..58ca1ff6d0 100644
--- a/collects/htdp/servlet.ss
+++ b/collects/htdp/servlet.ss
@@ -3,12 +3,23 @@
      (require (lib "servlet-env.ss" "web-server" "tools")
               (lib "error.ss" "htdp")
               (lib "xml.ss" "xml")
-              (lib "list.ss")
-              (lib "prim.ss" "lang")
-              (lib "unitsig.ss"))
-     (provide (all-from-except (lib "servlet-env.ss" "web-server" "tools") build-suspender)
+              (lib "etc.ss"))
+     (provide (all-from (lib "servlet-env.ss" "web-server" "tools"))
               (rename wrapped-build-suspender build-suspender))
      
+     ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
+     (define build-suspender
+       (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
+         (lambda (k-url)
+           `(html (head ,head-attributes
+                        (meta ([http-equiv "Pragma"] [content "no-cache"])) ; don't cache in netscape
+                        (meta ([http-equiv "Expires"] [content "-1"])) ; don't cache in IE
+                        ; one site said to use -1, another said to use 0.
+                        (title . ,title))
+                  (body ,body-attributes
+                        (form ([action ,k-url] [method "post"])
+                              ,@content))))))
+     
      (define wrapped-build-suspender
        (case-lambda
          [(title content)
@@ -42,4 +53,4 @@
      (define (attribute-pair? b)
        (and (pair? b)
             (symbol? (car b))
-            (string? (cdr b)))))
+            (string? (cdr b)))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/helper.ss b/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
index da23b180b1..a3132b3c6d 100644
--- a/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
+++ b/collects/web-server/default-web-root/servlets/examples/compound/helper.ss
@@ -11,11 +11,13 @@
                'n
                (request-bindings
                 (send/suspend
-                 (let ([prompt (string-append "Enter " which-number ": ")])
-                   (build-suspender
-                    (list prompt)
-                    `(,@error-message
-                        (p ,prompt (input ([type "text"] [name "n"])))
-                        (input ([type "submit"] [value "Okay"]))))))))]
+                 (lambda (k-url)
+                   (let ([prompt (string-append "Enter " which-number ": ")])
+                     `(html (head (title ,prompt))
+                            (body (form ([action ,k-url]
+                                         [method "post"])
+                                        ,@error-message
+                                        (p ,prompt (input ([type "text"] [name "n"])))
+                                        (input ([type "submit"] [value "Okay"]))))))))))]
              [n (string->number n-str)])
         (or n (ask `((p (font ([color "red"]) ,n-str) " is not a number.  Please enter a number."))))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss b/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
index 01881d92fd..36918bd640 100644
--- a/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
+++ b/collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
@@ -47,18 +47,18 @@
   (define (get-matrix-bindings rows columns)
     (request-bindings
      (send/suspend
-      (build-suspender
-       (list "Enter a " (number->string rows) " by "
-             (number->string columns) " Matrix")
-       `((table
-          . ,(build-list
-              rows
-              (lambda (r)
-                `(tr . ,(build-list
-                         columns
-                         (lambda (c)
-                           `(td (input ([type "text"] [name ,(field-name r c)])))))))))
-         (input ([type "submit"] [name "submit"] [value "Okay"])))))))
+      (lambda (k-url)
+        `(html (head (title "Enter a " ,(number->string rows) " by "
+                            ,(number->string columns) " Matrix"))
+               (body (form ([action ,k-url] [method "post"])
+                           (table ,(build-list
+                                    rows
+                                    (lambda (r)
+                                      `(tr . ,(build-list
+                                               columns
+                                               (lambda (c)
+                                                 `(td (input ([type "text"] [name ,(field-name r c)])))))))))
+                           (input ([type "submit"] [name "submit"] [value "Okay"])))))))))
   
   ; field-name : nat nat -> str
   (define (field-name row column)
diff --git a/collects/web-server/default-web-root/servlets/tests/cut-module.ss b/collects/web-server/default-web-root/servlets/tests/cut-module.ss
index 285391b98a..7dfb04b03b 100644
--- a/collects/web-server/default-web-root/servlets/tests/cut-module.ss
+++ b/collects/web-server/default-web-root/servlets/tests/cut-module.ss
@@ -13,9 +13,11 @@
                   'order
                   (request-bindings
                    (send/suspend (let ([question "Place your order"])
-                                   (build-suspender
-                                    `(,question)
-                                    `(,question (input ([type "text"] [name "order"]))))))))])
+                                   (lambda (k-url)
+                                     `(html (head (title ,question))
+                                            (body (form ([action ,k-url] [method "post"])
+                                                        ,question
+                                                        (input ([type "text"] [name "order"]))))))))))])
       (if (string=? "coconut" order)
           (continue-shopping)
           (retry-order))))
@@ -24,11 +26,12 @@
   (define (continue-shopping)
     (let* ([next-request
             (send/forward
-             (build-suspender
-              '("Keep shopping")
-              `((p "Your order has shipped to a random location.  You may not go back.")
-                (p (input ([type "submit"] [name "go"] [value "Keep Shopping"])))
-                (p (input ([type "submit"] [name "stop"] [value "Logout"]))))))]
+             (lambda (k-url)
+               `(html (head (title "Keep shopping"))
+                      (body (form ([action ,k-url] [method "post"])
+                                  (p "Your order has shipped to a random location.  You may not go back.")
+                                  (p (input ([type "submit"] [name "go"] [value "Keep Shopping"])))
+                                  (p (input ([type "submit"] [name "stop"] [value "Logout"]))))))))]
            [next (request-bindings next-request)])
       (cond
         [(exists-binding? 'go next)
@@ -49,6 +52,4 @@
   
   (define goodbye-page
     `(html (head (title "Goodbye"))
-           (body (p "Thank you for shopping.")))))
-  
-  
\ No newline at end of file
+           (body (p "Thank you for shopping.")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/error.ss b/collects/web-server/default-web-root/servlets/tests/error.ss
new file mode 100644
index 0000000000..8276136aa6
--- /dev/null
+++ b/collects/web-server/default-web-root/servlets/tests/error.ss
@@ -0,0 +1,11 @@
+(module error mzscheme
+  (require (lib "servlet.ss" "web-server"))
+  (provide (all-defined))
+  (define interface-version 'v1)
+  (define timeout +inf.0)
+  
+  (define (start initial-request)
+    (with-errors-to-browser
+     send/finish
+     (lambda ()
+       (error 'error "I am an error, do you see me?")))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/incremental.ss b/collects/web-server/default-web-root/servlets/tests/incremental.ss
index cf1ececed2..b169c42268 100644
--- a/collects/web-server/default-web-root/servlets/tests/incremental.ss
+++ b/collects/web-server/default-web-root/servlets/tests/incremental.ss
@@ -5,7 +5,8 @@
   (define timeout +inf.0)
   (define (start initial-request)
     (send/finish
-     (make-html-response/incremental
+     (make-response/incremental
+      200 "Okay" (current-seconds) #"text/html" '()
       (lambda (output-chunk)
         (output-chunk ""
                       "my-title\n")
diff --git a/collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss b/collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss
index 4384781ed8..cee311cec4 100644
--- a/collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss
+++ b/collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss
@@ -12,14 +12,18 @@
                  'name
                  (request-bindings
                   (send/suspend (let ([question "What is your name?"])
-                                  (build-suspender
-                                   `(,question)
-                                   `(,question (input ([type "text"] [name "name"]))))))))])
+                                  (lambda (k-url)
+                                    `(html (head (title ,question))
+                                           (body (form ([action ,k-url] [method "post"])
+                                                       ,question
+                                                       (input ([type "text"] [name "order"]))))))))))])
       `(html (head (title "Hi " ,name "!"))
              (body (p "Hello, " ,name "!  Don't you feel special now?")))))
   
   (send/suspend
-   (build-suspender '("Module Init")
-                    '((p "Maybe calling send/suspend during the module initialization is not a good idea.")
-                      (p "This call to send/suspend fails in the development environment since the parameter is #f")
-                      (p "It fails in the server because the instance id is not yet installed into the table.")))))
\ No newline at end of file
+   (lambda (k-url)
+     `(html (head (title "Module Init"))
+            (body (form ([action ,k-url] [method "post"])
+                        (p "Maybe calling send/suspend during the module initialization is not a good idea.")
+                        (p "This call to send/suspend fails in the development environment since the parameter is #f")
+                        (p "It fails in the server because the instance id is not yet installed into the table.")))))))
\ No newline at end of file
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss
deleted file mode 100644
index 078eba9382..0000000000
--- a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss
+++ /dev/null
@@ -1,14 +0,0 @@
-(module jas01-fix mzscheme
-  (require (lib "servlet.ss" "web-server")
-           "jas01-fix-param.ss")
-
-  (provide interface-version timeout start)
-  (define interface-version 'v1)
-  (define timeout +inf.0)
-
-  ; start : request -> response
-  (define (start initial-request)
-    (report-errors-to-browser send/finish)
-    `(html (head (title "Servlet Parameter Test"))
-           (body (h1 "Servlet Parameter Test")
-                 ,(number->string (get-time))))))
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss
deleted file mode 100644
index 9499c25e1d..0000000000
--- a/collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss
+++ /dev/null
@@ -1,14 +0,0 @@
-(module jas01 mzscheme
-  (require (lib "servlet.ss" "web-server")
-           "jas01-param.ss")
-
-  (provide interface-version timeout start)
-  (define interface-version 'v1)
-  (define timeout +inf.0)
-
-  ; start : request -> response
-  (define (start initial-request)
-    (report-errors-to-browser send/finish)
-    `(html (head (title "Servlet Parameter Test"))
-           (body (h1 "Servlet Parameter Test")
-                 ,(number->string (get-time))))))
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss
deleted file mode 100644
index 6cb1cee646..0000000000
--- a/collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss
+++ /dev/null
@@ -1,19 +0,0 @@
-(module pr5565 mzscheme
-  (require (lib "servlet.ss" "web-server"))
-  (provide (all-defined))
-  
-  (define interface-version 'v1)
-  (define timeout 120)
-  (define (start ireq)
-    (define p
-      (send/suspend
-       (build-suspender `("Test of Page 2")
-                        `((input ([type "submit"][value "pls test with and without topping"]))))))    
-    (define q
-      (send/suspend
-       (build-suspender `("Bug")
-                        `((input ([type "text"][name "x"]))))))    
-    (define r (extract-binding/single `x (request-bindings q)))   
-    (send/suspend
-     (build-suspender `("Result of test")
-                      (list r)))))
diff --git a/collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss b/collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss
deleted file mode 100644
index b4245260dc..0000000000
--- a/collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss
+++ /dev/null
@@ -1,10 +0,0 @@
-(module pr7935-other mzscheme
-  (require (lib "servlet.ss" "web-server"))
-  (provide (all-defined))
-  
-  (define interface-version 'v1)
-  (define timeout 60)
-  
-  (define (start initial-request)
-    ;(report-errors-to-browser send/back)
-    (/ 1 0)))
diff --git a/collects/web-server/default-web-root/servlets/tests/suspended-module.ss b/collects/web-server/default-web-root/servlets/tests/suspended-module.ss
index 9137a17174..6c4ce3890e 100644
--- a/collects/web-server/default-web-root/servlets/tests/suspended-module.ss
+++ b/collects/web-server/default-web-root/servlets/tests/suspended-module.ss
@@ -12,8 +12,10 @@
                  'name
                  (request-bindings
                   (send/suspend (let ([question "What is your name?"])
-                                  (build-suspender
-                                   `(,question)
-                                   `(,question (input ([type "text"] [name "name"]))))))))])
+                                  (lambda (k-url)
+                                    `(html (head (title ,question))
+                                           (body (form ([action ,k-url] [method "post"])
+                                                       ,question
+                                                       (input ([type "text"] [name "order"]))))))))))])
       `(html (head (title "Hi " ,name "!"))
              (body (p "Hello, " ,name "!  Don't you feel special now?"))))))
\ No newline at end of file
diff --git a/collects/web-server/dispatchers/dispatch-host.ss b/collects/web-server/dispatchers/dispatch-host.ss
index f85baf6a42..e2ee8f2870 100644
--- a/collects/web-server/dispatchers/dispatch-host.ss
+++ b/collects/web-server/dispatchers/dispatch-host.ss
@@ -1,7 +1,9 @@
 (module dispatch-host mzscheme
-  (require (lib "contract.ss"))
-  (require "dispatch.ss"
-           "../private/servlet-helpers.ss")
+  (require (lib "contract.ss")
+           (lib "plt-match.ss")
+           (lib "url.ss" "net")
+           "../request-structs.ss"
+           "dispatch.ss")
   (provide/contract
    [interface-version dispatcher-interface-version?]
    [make ((symbol? . -> . dispatcher?) . -> . dispatcher?)])
@@ -9,4 +11,15 @@
   (define interface-version 'v1)
   (define ((make lookup-dispatcher) conn req)
     (define host (get-host (request-uri req) (request-headers/raw req)))
-    ((lookup-dispatcher host) conn req)))
\ No newline at end of file
+    ((lookup-dispatcher host) conn req))
+  
+  ;; get-host : Url (listof (cons Symbol String)) -> Symbol
+  ;; XXX host names are case insesitive---Internet RFC 1034
+  (define (get-host uri headers)
+    (cond
+      [(url-host uri) => string->symbol]
+      [(headers-assq* #"Host" headers)
+       => (match-lambda
+            [(struct header (_ v))
+             (string->symbol (bytes->string/utf-8 v))])]
+      [else '])))
\ No newline at end of file
diff --git a/collects/web-server/private/configure.ss b/collects/web-server/private/configure.ss
index ec87e7344f..4a13056301 100644
--- a/collects/web-server/private/configure.ss
+++ b/collects/web-server/private/configure.ss
@@ -30,6 +30,19 @@
   ; - change all configuration paths (in the configure servlet and in the server) to
   ;   use a platform independent representation (i.e. a listof strings)
   
+    ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
+  (define build-suspender
+    (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
+      (lambda (k-url)
+        `(html (head ,head-attributes
+                     (meta ([http-equiv "Pragma"] [content "no-cache"])) ; don't cache in netscape
+                     (meta ([http-equiv "Expires"] [content "-1"])) ; don't cache in IE
+                     ; one site said to use -1, another said to use 0.
+                     (title . ,title))
+               (body ,body-attributes
+                     (form ([action ,k-url] [method "post"])
+                           ,@content))))))
+  
   (define default-configuration-path default-configuration-table-path)
   (define (set-config-path! new)
     (set! default-configuration-path new))
diff --git a/collects/web-server/private/servlet-helpers.ss b/collects/web-server/private/servlet-helpers.ss
index f1cb515035..8d3bed700e 100644
--- a/collects/web-server/private/servlet-helpers.ss
+++ b/collects/web-server/private/servlet-helpers.ss
@@ -2,17 +2,15 @@
   (require (lib "contract.ss")
            (lib "etc.ss")
            (lib "plt-match.ss")
-           (lib "xml.ss" "xml")
            (lib "base64.ss" "net")
-           (lib "url.ss" "net")
            (lib "uri-codec.ss" "net"))
   (require "util.ss"
            "bindings.ss"
-           "../servlet-structs.ss"
            "../request-structs.ss"
            "../response-structs.ss")
   (provide (all-from "bindings.ss")
-           (all-from "../request-structs.ss"))  
+           (all-from "../response-structs.ss")
+           (all-from "../request-structs.ss"))
   
   (define (request-headers request)
     (map (match-lambda
@@ -30,31 +28,6 @@
                   value)])
          (request-bindings/raw request)))
   
-  ;; get-host : Url (listof (cons Symbol String)) -> Symbol
-  ;; host names are case insesitive---Internet RFC 1034
-  (define DEFAULT-HOST-NAME ')
-  (define (get-host uri headers)
-    (cond
-      [(url-host uri) => string->symbol]
-      [(headers-assq* #"Host" headers)
-       => (match-lambda
-            [(struct header (_ v))
-             (string->symbol (bytes->string/utf-8 v))])]
-      [else DEFAULT-HOST-NAME]))
-  
-  ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
-  (define build-suspender
-    (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
-      (lambda (k-url)
-        `(html (head ,head-attributes
-                     (meta ([http-equiv "Pragma"] [content "no-cache"])) ; don't cache in netscape
-                     (meta ([http-equiv "Expires"] [content "-1"])) ; don't cache in IE
-                     ; one site said to use -1, another said to use 0.
-                     (title . ,title))
-               (body ,body-attributes
-                     (form ([action ,k-url] [method "post"])
-                           ,@content))))))
-  
   ; redirection-status = (make-redirection-status nat str)
   (define-struct redirection-status (code message))
   
@@ -68,34 +41,21 @@
       (make-response/full (redirection-status-code perm/temp)
                           (redirection-status-message perm/temp)
                           (current-seconds) #"text/html"
-                          `((Location . ,uri)) (list (redirect-page uri)))))
+                          `((Location . ,uri)) (list))))
   
-  ; : str -> str
-  (define (redirect-page url)
-    (xexpr->string `(html (head (meta ((http-equiv "refresh") (url ,url)))
-                                "Redirect to " ,url)
-                          (body (p "Redirecting to " (a ([href ,url]) ,url))))))
-  
-  ; make-html-response/incremental : ((string -> void) -> void) -> response/incremental
-  (define (make-html-response/incremental chunk-maker)
-    (make-response/incremental
-     200 "Okay" (current-seconds) #"text/html" '()
-     chunk-maker))
-  
-  ; : (response -> doesn't) -> void
+  ; with-errors-to-browser 
   ; to report exceptions that occur later to the browser
   ; this must be called at the begining of a servlet
-  (define (report-errors-to-browser send/finish-or-back)
-    (uncaught-exception-handler
-     (lambda (exn)
-       (send/finish-or-back
-        `(html (head (title "Servlet Error"))
-               (body ([bgcolor "white"])
-                     (p "The following error occured: "
-                        (pre ,(exn->string exn)))))))))
-  
-  ; Authentication
+  (define (with-errors-to-browser send/finish-or-back thunk)
+    (with-handlers ([exn? (lambda (exn)
+                            (send/finish-or-back
+                             `(html (head (title "Servlet Error"))
+                                    (body ([bgcolor "white"])
+                                          (p "The following error occured: "
+                                             (pre ,(exn->string exn)))))))])
+      (thunk)))
   
+  ; Authentication  
   (define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)"))
   (define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x))
   ;:(define match-authentication (type: (str -> (or/c false (list str str str)))))
@@ -125,20 +85,12 @@
     (let ([rx (byte-regexp #"^Basic .*")])
       (lambda (a) (regexp-match rx a))))
   
-  
-  
   (provide ; all-from
+   with-errors-to-browser
    (rename uri-decode translate-escapes))
   (provide/contract
-   [get-host (url? (listof header?) . -> . symbol?)]
-   ; XXX contract maybe
+   ; XXX contract maybe   
    [extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))]
-   [build-suspender (((listof xexpr?) (listof xexpr?))
-                     ((listof (list/c symbol? string?)) (listof (list/c symbol? string?)))
-                     . opt-> .
-                     (k-url? . -> . xexpr?))]
-   [make-html-response/incremental (((string? . -> . void) . -> . void) . -> . response/incremental?)]
-   [report-errors-to-browser ((servlet-response? . -> . void) . -> . void)]
    [redirect-to ((string?) (redirection-status?) . opt-> . response/full?)]
    [permanently redirection-status?]
    [temporarily redirection-status?]
diff --git a/collects/web-server/prototype-web-server/lang-api/web-extras.ss b/collects/web-server/prototype-web-server/lang-api/web-extras.ss
index dd0f0b0fed..209ee6b693 100644
--- a/collects/web-server/prototype-web-server/lang-api/web-extras.ss
+++ b/collects/web-server/prototype-web-server/lang-api/web-extras.ss
@@ -1,14 +1,23 @@
 (module web-extras mzscheme
-  (require (lib "contract.ss")
-           (lib "etc.ss")
-           (lib "plt-match.ss")
-           (lib "base64.ss" "net")
-           (lib "url.ss" "net")
-           "../../request-structs.ss"
-           "../../response-structs.ss"
-           "../private/web.ss")  
+  (require (lib "url.ss" "net")
+           "../private/web.ss"
+           (only "../../private/servlet-helpers.ss"
+                 extract-user-pass
+                 redirect-to
+                 permanently
+                 temporarily
+                 see-other
+                 request-bindings
+                 request-headers))
   (provide send/suspend/dispatch
-           redirect/get)
+           redirect/get
+           extract-user-pass
+           redirect-to
+           permanently
+           temporarily
+           see-other
+           request-bindings
+           request-headers)
   
   (define-syntax send/suspend/dispatch
     (syntax-rules ()
@@ -21,55 +30,4 @@
               (embed-proc/url k-url proc))))))]))  
   
   (define (redirect/get)
-    (send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily))))
-    
-  ; redirection-status = (make-redirection-status nat str)
-  (define-struct redirection-status (code message))
-  
-  (define permanently (make-redirection-status 301 "Moved Permanently"))
-  (define temporarily (make-redirection-status 302 "Moved Temporarily"))
-  (define see-other (make-redirection-status 303 "See Other"))
-  
-  ; : str [redirection-status] -> response
-  (define redirect-to
-    (opt-lambda (uri [perm/temp permanently])
-      (make-response/full (redirection-status-code perm/temp)
-                          (redirection-status-message perm/temp)
-                          (current-seconds) #"text/html"
-                          `((Location . ,uri)) (list))))
-  
-  ; make-html-response/incremental : ((string -> void) -> void) -> response/incremental
-  (define (make-html-response/incremental chunk-maker)
-    (make-response/incremental
-     200 "Okay" (current-seconds) #"text/html" '()
-     chunk-maker))
-  
-  ; Authentication  
-  ; basic-auth-extract-user-pass : (listof (cons sym bytes)) -> (or/c #f (cons str str))
-  ;; Notes (GregP)
-  ;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1)
-  ;;    e.g. an authorization header will look like this:
-  ;;         Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==
-  ;; 2. Headers should be read as bytes and then translated to unicode as appropriate.
-  ;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes
-  (define (basic-auth-extract-user-pass headers)
-    (match (headers-assq* #"Authorization" headers)
-      [#f #f]
-      [(struct header (_ basic-credentials))
-       (cond
-         [(and (regexp-match #rx#"^Basic .*"
-                             basic-credentials)
-               (regexp-match #rx"([^:]*):(.*)"
-                             (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))))
-          => (lambda (user-pass)
-               (cons (cadr user-pass) (caddr user-pass)))]
-         [else #f])]))
-  
-  (provide/contract
-   ; XXX contract maybe
-   [basic-auth-extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))]   
-   [make-html-response/incremental (((string? . -> . void) . -> . void) . -> . response/incremental?)]
-   [redirect-to ((string?) (redirection-status?) . opt-> . response/full?)]
-   [permanently redirection-status?]
-   [temporarily redirection-status?]
-   [see-other redirection-status?]))
\ No newline at end of file
+    (send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily)))))
\ No newline at end of file