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

Removing obsolete functions and fixing report-errors-to-browser, which did not work

Browse Source 
svn: r6402
This commit is contained in:
Jay McCarthy 2007-05-30 15:10:24 +00:00
parent d0b2f86f30
commit 4cdddaec1a
53 changed files with 1110 additions and 1140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,11 +6,13 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html (head (title "Acknowledgements")) send/finish
(body (a ([name "acknowledgements"] [value "acknowledgements"])) (lambda ()
(h1 "Acknowledgements") `(html (head (title "Acknowledgements"))
(p) (body (a ([name "acknowledgements"] [value "acknowledgements"]))
,(get-general-acks) (h1 "Acknowledgements")
(p) (p)
,(get-translating-acks))))) ,(get-general-acks)
(p)
,(get-translating-acks)))))))

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

@ -5,12 +5,14 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
(let* ([bindings (request-bindings initial-request)] send/finish
[offset (with-handlers ((void (lambda _ #f))) (lambda ()
(string->number (let* ([bindings (request-bindings initial-request)]
(extract-binding/single 'offset bindings)))]) [offset (with-handlers ((void (lambda _ #f)))
(read-doc (extract-binding/single 'file bindings) (string->number
(extract-binding/single 'caption bindings) (extract-binding/single 'offset bindings)))])
(extract-binding/single 'name bindings) (read-doc (extract-binding/single 'file bindings)
offset)))) (extract-binding/single 'caption bindings)
(extract-binding/single 'name bindings)
offset))))))

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

@ -6,14 +6,16 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
(let* ([bindings (request-bindings initial-request)] send/finish
[file (extract-binding/single 'file bindings)] (lambda ()
[caption (extract-binding/single 'caption bindings)] (let* ([bindings (request-bindings initial-request)]
[offset (with-handlers ((void (lambda _ #f))) [file (extract-binding/single 'file bindings)]
(string->number [caption (extract-binding/single 'caption bindings)]
(extract-binding/single 'offset bindings)))]) [offset (with-handlers ((void (lambda _ #f)))
`(html (head (title "PLT Help Desk") (string->number
,hd-css (extract-binding/single 'offset bindings)))])
,@hd-links) `(html (head (title "PLT Help Desk")
,(read-lines file caption offset))))) ,hd-css
,@hd-links)
,(read-lines file caption offset)))))))

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

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

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

@ -12,19 +12,19 @@
(define items (define items
`(("Help Desk" "How to get help" "/servlets/howtouse.ss") `(("Help Desk" "How to get help" "/servlets/howtouse.ss")
("Software" "How to run programs" "/servlets/howtoscheme.ss" ("Software" "How to run programs" "/servlets/howtoscheme.ss"
,(lambda () `("Tour" ,(get-manual-index "tour"))) ,(lambda () `("Tour" ,(get-manual-index "tour")))
("Languages" "/servlets/scheme/what.ss") ("Languages" "/servlets/scheme/what.ss")
("Manuals" "/servlets/manuals.ss") ("Manuals" "/servlets/manuals.ss")
("Release" "/servlets/releaseinfo.ss") ("Release" "/servlets/releaseinfo.ss")
,(lambda () ,(lambda ()
(manual-entry "drscheme" "frequently asked questions" "FAQ"))) (manual-entry "drscheme" "frequently asked questions" "FAQ")))
("Program Design" "Learning to program in Scheme" "/servlets/howtoprogram.ss" ("Program Design" "Learning to program in Scheme" "/servlets/howtoprogram.ss"
("Teachpacks" "/servlets/teachpacks.ss") ("Teachpacks" "/servlets/teachpacks.ss")
("Why DrScheme?" "/servlets/research/why.ss")) ("Why DrScheme?" "/servlets/research/why.ss"))
("External Resources" "Additional information" "/servlets/resources.ss" ("External Resources" "Additional information" "/servlets/resources.ss"
("TeachScheme!" "/servlets/resources/teachscheme.ss") ("TeachScheme!" "/servlets/resources/teachscheme.ss")
("Libraries" "/servlets/resources/libext.ss") ("Libraries" "/servlets/resources/libext.ss")
("Mailing Lists" "/servlets/resources/maillist.ss")))) ("Mailing Lists" "/servlets/resources/maillist.ss"))))
(define (item i) (define (item i)
(define (item->xexpr item) (define (item->xexpr item)
@ -33,29 +33,31 @@
[else `(a ([href ,(cadr item)]) ,(car item))])) [else `(a ([href ,(cadr item)]) ,(car item))]))
(let ([title (car i)] [subtitle (cadr i)] [url (caddr i)] [subs (cdddr i)]) (let ([title (car i)] [subtitle (cadr i)] [url (caddr i)] [subs (cdddr i)])
`(li (b (a ([href ,url]) ,title)) ": " ,subtitle `(li (b (a ([href ,url]) ,title)) ": " ,subtitle
,@(if (null? subs) ,@(if (null? subs)
'() '()
`((br) nbsp nbsp nbsp nbsp nbsp nbsp `((br) nbsp nbsp nbsp nbsp nbsp nbsp
(font ([size "-2"]) (font ([size "-2"])
,@(apply append (map (lambda (s) `(,(item->xexpr s) ", ")) ,@(apply append (map (lambda (s) `(,(item->xexpr s) ", "))
subs)) subs))
"..."))) "...")))
(br) (br)))) (br) (br))))
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html send/finish
(head (title "PLT Help Desk")) (lambda ()
(body `(html
(table ([cellspacing "0"] [cellpadding "0"]) (head (title "PLT Help Desk"))
(tr (td (h1 "PLT Help Desk") (body
(ul ,@(map item items)) (table ([cellspacing "0"] [cellpadding "0"])
(p) nbsp nbsp nbsp (tr (td (h1 "PLT Help Desk")
(b (a ((href "/servlets/acknowledge.ss")) (ul ,@(map item items))
(font ([color "forestgreen"]) "Acknowledgements"))) (p) nbsp nbsp nbsp
nbsp nbsp nbsp nbsp (b (a ((href "/servlets/acknowledge.ss"))
(b (a ([mzscheme (font ([color "forestgreen"]) "Acknowledgements")))
"((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"]) nbsp nbsp nbsp nbsp
(font ([color "forestgreen"]) "Send a bug report"))) (b (a ([mzscheme
(p) "((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"])
(i "Version: " ,(plt-version))))))))) (font ([color "forestgreen"]) "Send a bug report")))
(p)
(i "Version: " ,(plt-version)))))))))))

40
collects/help/servlets/howtodrscheme.ss
View File

@ -6,22 +6,24 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html send/finish
(head ,hd-css ,@hd-links (title "DrScheme")) (lambda ()
(body `(html
(h1 "DrScheme") (head ,hd-css ,@hd-links (title "DrScheme"))
"DrScheme is PLT's flagship programming environment. " (body
"See " (a ((href "/servlets/scheme/how.ss")) "Software & Components") (h1 "DrScheme")
" for a guide to the full suite of PLT tools." "DrScheme is PLT's flagship programming environment. "
(ul (li (b (a ([href ,(get-manual-index "tour")])) "Tour") "See " (a ((href "/servlets/scheme/how.ss")) "Software & Components")
": An introduction to DrScheme") " for a guide to the full suite of PLT tools."
(li (b ,(manual-entry "drscheme" (ul (li (b (a ([href ,(get-manual-index "tour")])) "Tour")
"graphical interface" ": An introduction to DrScheme")
"Interface Essentials")) (li (b ,(manual-entry "drscheme"
": Quick-start jump into the user manual") "graphical interface"
(li (b (a ([href "/servlets/scheme/what.ss"]) "Interface Essentials"))
"Languages")) ": Quick-start jump into the user manual")
": Languages supported by DrScheme") (li (b (a ([href "/servlets/scheme/what.ss"])
(li (b ,(main-manual-page "drscheme")) "Languages"))
": The complete user manual")))))) ": Languages supported by DrScheme")
(li (b ,(main-manual-page "drscheme"))
": The complete user manual"))))))))

50
collects/help/servlets/howtoprogram.ss
View File

@ -7,27 +7,29 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html send/finish
(head ,hd-css ,@hd-links (title "Program Design")) (lambda ()
(body `(html
(h1 "Program Design") (head ,hd-css ,@hd-links (title "Program Design"))
,(color-highlight `(h2 "For Students")) (body
"The textbook " (i "How to Design Programs") (h1 "Program Design")
" provides an introduction to programming using the DrScheme" ,(color-highlight `(h2 "For Students"))
" environment. The book is not distributed with DrScheme, but it" "The textbook " (i "How to Design Programs")
" is available online at " " provides an introduction to programming using the DrScheme"
(pre " " (a ([href "http://www.htdp.org/"] [target "_top"]) " environment. The book is not distributed with DrScheme, but it"
"http://www.htdp.org/")) " is available online at "
(p) (pre " " (a ([href "http://www.htdp.org/"] [target "_top"])
"Help Desk provides the following interactive support for the textbook:" "http://www.htdp.org/"))
(ul (li (b (a ([href "/servlets/teachpacks.ss"]) (p)
"Teachpack documentation")))) "Help Desk provides the following interactive support for the textbook:"
(p) (ul (li (b (a ([href "/servlets/teachpacks.ss"])
,(color-highlight `(h2 "For Experienced Programmers")) "Teachpack documentation"))))
(ul (li (b (a ((href ,(get-manual-index "t-y-scheme"))) (p)
"Teach Yourself Scheme in Fixnum Days")) ,(color-highlight `(h2 "For Experienced Programmers"))
": For programmers with lots of experience in other languages")) (ul (li (b (a ((href ,(get-manual-index "t-y-scheme")))
,(color-highlight `(h2 "For Teachers and Researchers")) "Teach Yourself Scheme in Fixnum Days"))
(ul (li (b (a ([href "/servlets/research/why.ss"]) "Why DrScheme?")) ": For programmers with lots of experience in other languages"))
": PLT's vision ")))))) ,(color-highlight `(h2 "For Teachers and Researchers"))
(ul (li (b (a ([href "/servlets/research/why.ss"]) "Why DrScheme?"))
": PLT's vision "))))))))

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

@ -6,7 +6,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Software")) (head ,hd-css ,@hd-links (title "Software"))
(body (body
@ -33,4 +35,4 @@
(li (b ,(manual-entry "drscheme" "frequently asked questions" "FAQ")) (li (b ,(manual-entry "drscheme" "frequently asked questions" "FAQ"))
": Frequently asked questions") ": Frequently asked questions")
(li (b (a ([href "releaseinfo.ss"]) "Release Information")) (li (b (a ([href "releaseinfo.ss"]) "Release Information"))
": License, notes, and known bugs")))))) ": License, notes, and known bugs"))))))))

126
collects/help/servlets/howtouse.ss
View File

@ -7,65 +7,67 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html send/finish
(head ,hd-css ,@hd-links (title "Help Desk")) (lambda ()
(body `(html
(h1 "Help Desk") (head ,hd-css ,@hd-links (title "Help Desk"))
(p) (body
(a ([name "helpme"] [value "Help Desk"])) (h1 "Help Desk")
"Help Desk (the program you're currently running) is a " (p)
"complete source of information about PLT software, " (a ([name "helpme"] [value "Help Desk"]))
"including DrScheme, MzScheme, and MrEd." "Help Desk (the program you're currently running) is a "
(p) "complete source of information about PLT software, "
"Use Help Desk to find information in either of two ways:" "including DrScheme, MzScheme, and MrEd."
(p) (p)
,(color-highlight "Use Help Desk to find information in either of two ways:"
"1. Navigate the Help Desk information pages by" (p)
" clicking on hyperlinks.") ,(color-highlight
(ul "1. Navigate the Help Desk information pages by"
(li "The " (b ,(string-constant home)) " button " " clicking on hyperlinks.")
"at the top of the page always takes " (ul
"you back to the starting page.") (li "The " (b ,(string-constant home)) " button "
(li "The " (b "Manuals") " link (in the " (b "Software") " section on the main page) displays a list" "at the top of the page always takes "
" of manuals and other documentation.") "you back to the starting page.")
(li "The " (b "Send a bug report") (li "The " (b "Manuals") " link (in the " (b "Software") " section on the main page) displays a list"
" link allows you to submit bug reports to PLT.")) " of manuals and other documentation.")
(p) (li "The " (b "Send a bug report")
(a ([name "helpsearch"] [value "Searching in Help Desk"])) " link allows you to submit bug reports to PLT."))
(a ([name "search"])) (p)
,(color-highlight (a ([name "helpsearch"] [value "Searching in Help Desk"]))
"2. Search for terms using the " (a ([name "search"]))
`(b "Find docs for") " field at the bottom of Help Desk.") ,(color-highlight
(ul "2. Search for terms using the "
(li "Enter one or more terms into the " (b "Find docs for") " field.") `(b "Find docs for") " field at the bottom of Help Desk.")
(li "Click the " (b "Search") " button " (ul
"(or hit Enter) to start a search, " (li "Enter one or more terms into the " (b "Find docs for") " field.")
"or choose the " (b "Feeling Lucky") " menu item.") (li "Click the " (b "Search") " button "
(li "If you click on the " (b "Search") " button, " "(or hit Enter) to start a search, "
"Help Desk scans the documentation pages and " "or choose the " (b "Feeling Lucky") " menu item.")
"returns a list of hyperlinks for " (li "If you click on the " (b "Search") " button, "
(i "keyword") ", " "Help Desk scans the documentation pages and "
(i "index entry") ", and " "returns a list of hyperlinks for "
(i "raw text") " matches:" (i "keyword") ", "
(ul (li (i "Keywords") " are Scheme names, such as " (tt "define") (i "index entry") ", and "
" and " (tt "cons") ".") (i "raw text") " matches:"
(li (i "Index entries") (ul (li (i "Keywords") " are Scheme names, such as " (tt "define")
" are topical phrases, such as \"lists\".") " and " (tt "cons") ".")
(li (i "Raw text") " results are fragments of " (li (i "Index entries")
"text from the documentation pages. " " are topical phrases, such as \"lists\".")
"(Raw text results are useful only as " (li (i "Raw text") " results are fragments of "
"a last resort.)"))) "text from the documentation pages. "
(li "If you perform a lucky search, " "(Raw text results are useful only as "
"Help Desk goes directly to the first item of documentation " "a last resort.)")))
"that matches the search term, without displaying links to " (li "If you perform a lucky search, "
"all relevant items.")) "Help Desk goes directly to the first item of documentation "
(p) "that matches the search term, without displaying links to "
"Help Desk sorts search results according to their source." "all relevant items."))
(p) (p)
"If you open Help Desk inside DrScheme, the search results are " "Help Desk sorts search results according to their source."
"filtered based on the language you are using. Use " (p)
(b "Choose Language...") "If you open Help Desk inside DrScheme, the search results are "
" menu item from the " "filtered based on the language you are using. Use "
(b "Language") (b "Choose Language...")
" menu to change the language.")))) " menu item from the "
(b "Language")
" menu to change the language."))))))

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

@ -7,25 +7,27 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
(let* ([bindings (request-bindings initial-request)] send/finish
[manual (extract-binding/single 'manual bindings)] (lambda ()
[raw-section (extract-binding/single 'section bindings)] (let* ([bindings (request-bindings initial-request)]
;; remove quotes [manual (extract-binding/single 'manual bindings)]
[section (substring raw-section [raw-section (extract-binding/single 'section bindings)]
1 (sub1 (string-length raw-section)))] ;; remove quotes
[page (with-handlers [section (substring raw-section
([void (lambda _ 1 (sub1 (string-length raw-section)))]
(send/finish [page (with-handlers
`(html ([void (lambda _
(head ,hd-css ,@hd-links (send/finish
(title "Can't find manual section")) `(html
(body (head ,hd-css ,@hd-links
"Error looking up PLT manual section" (title "Can't find manual section"))
(p) (body
"Requested manual: " "Error looking up PLT manual section"
,manual (br) (p)
"Requested section: " "Requested manual: "
,section))))]) ,manual (br)
(finddoc-page-anchor manual section))]) "Requested section: "
(send/finish (redirect-to page))))) ,section))))])
(finddoc-page-anchor manual section))])
(send/finish (redirect-to page)))))))

6
collects/help/servlets/manuals.ss
View File

@ -5,5 +5,7 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
(list #"text/html" (find-manuals)))) send/finish
(lambda ()
(list #"text/html" (find-manuals))))))

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

@ -8,11 +8,13 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
(let ([bindings (request-bindings initial-request)]) send/finish
(no-manual (extract-binding/single 'manual bindings) (lambda ()
(extract-binding/single 'name bindings) (let ([bindings (request-bindings initial-request)])
(extract-binding/single 'link bindings)))) (no-manual (extract-binding/single 'manual bindings)
(extract-binding/single 'name bindings)
(extract-binding/single 'link bindings))))))
(define (no-manual manual label link) (define (no-manual manual label link)
(let* ([html-url (make-docs-html-url manual)] (let* ([html-url (make-docs-html-url manual)]
@ -20,22 +22,22 @@
`(html `(html
(head ,hd-css ,@hd-links (title "Missing PLT manual")) (head ,hd-css ,@hd-links (title "Missing PLT manual"))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
,(with-color "red" `(h1 "Documentation missing")) ,(with-color "red" `(h1 "Documentation missing"))
(p) (p)
"You tried to access documentation for " "You tried to access documentation for "
,(with-color "blue" `(b ,label)) ". " ,(with-color "blue" `(b ,label)) ". "
"The documentation is not installed on this machine, probably" "The documentation is not installed on this machine, probably"
" because it is not part of the standard DrScheme distribution." " because it is not part of the standard DrScheme distribution."
(p) (p)
(h2 "Install Locally") (h2 "Install Locally")
(a ((href ,plt-url)) "Download and/or install") (a ((href ,plt-url)) "Download and/or install")
" the documentation." " the documentation."
(br) (br)
"After installing, " "After installing, "
(a ((href ,link)) "continue") (a ((href ,link)) "continue")
" to the originally requested page." " to the originally requested page."
(br) nbsp (br) (br) nbsp (br)
(h2 "Read Online") (h2 "Read Online")
"Read the documentation on " "Read the documentation on "
(a ((href ,html-url)) "PLT's servers") (a ((href ,html-url)) "PLT's servers")
"."))))) ".")))))

6
collects/help/servlets/release/bugs.ss
View File

@ -7,7 +7,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Known Bugs")) (head ,hd-css ,@hd-links (title "Known Bugs"))
(body (body
@ -15,4 +17,4 @@
(a ([name "bugs"] [value "Bugs"])) (a ([name "bugs"] [value "Bugs"]))
"For an up-to-date list of bug reports, see the " "For an up-to-date list of bug reports, see the "
(a ([href "http://bugs.plt-scheme.org/query/"] [target "_top"]) (a ([href "http://bugs.plt-scheme.org/query/"] [target "_top"])
"PLT bug report query page")) "."))) "PLT bug report query page")) ".")))))

6
collects/help/servlets/release/license.ss
View File

@ -11,7 +11,9 @@
`(ul (li ,@(map (lambda (s) `(div ,s (br))) ss)))) `(ul (li ,@(map (lambda (s) `(div ,s (br))) ss))))
(define copyright-year 2007) (define copyright-year 2007)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "License")) (head ,hd-css ,@hd-links (title "License"))
(body (body
@ -88,4 +90,4 @@
("GNU lightning" ("GNU lightning"
"Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.") "Copyright (c) 1994, 1995, 1996, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.")
("GNU Classpath" ("GNU Classpath"
"GNU Public License with special exception"))))))) "GNU Public License with special exception")))))))))

6
collects/help/servlets/release/notes.ss
View File

@ -22,7 +22,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "PLT release notes")) (head ,hd-css ,@hd-links (title "PLT release notes"))
(body (body
@ -39,4 +41,4 @@
("MzScheme release notes" "mzscheme" "HISTORY") ("MzScheme release notes" "mzscheme" "HISTORY")
("MrEd release notes" "mred" "HISTORY") ("MrEd release notes" "mred" "HISTORY")
("Stepper release notes" "stepper" "HISTORY") ("Stepper release notes" "stepper" "HISTORY")
("MrFlow release notes" "mrflow" "HISTORY"))))))))) ("MrFlow release notes" "mrflow" "HISTORY")))))))))))

6
collects/help/servlets/release/patches.ss
View File

@ -6,7 +6,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Downloadable Patches")) (head ,hd-css ,@hd-links (title "Downloadable Patches"))
(body (body
@ -18,4 +20,4 @@
nbsp nbsp nbsp nbsp
,(let ([url (format "http://download.plt-scheme.org/patches/~a/" ,(let ([url (format "http://download.plt-scheme.org/patches/~a/"
(version))]) (version))])
`(a ([href ,url] [target "_top"]) ,url)))))) `(a ([href ,url] [target "_top"]) ,url))))))))

6
collects/help/servlets/releaseinfo.ss
View File

@ -10,7 +10,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Release Information")) (head ,hd-css ,@hd-links (title "Release Information"))
(body (body
@ -29,4 +31,4 @@
(pre nbsp nbsp (pre nbsp nbsp
,(let-values ([(base file dir?) ,(let-values ([(base file dir?)
(split-path (collection-path "mzlib"))]) (split-path (collection-path "mzlib"))])
(path->string base))))))) (path->string base)))))))))

6
collects/help/servlets/research/why.ss
View File

@ -6,7 +6,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Why DrScheme?")) (head ,hd-css ,@hd-links (title "Why DrScheme?"))
(body (body
@ -57,4 +59,4 @@
" paper: " " paper: "
(a ([href "http://www.ccs.neu.edu/scheme/pubs#jfp01-fcffksf"] (a ([href "http://www.ccs.neu.edu/scheme/pubs#jfp01-fcffksf"]
[target "_top"]) [target "_top"])
"DrScheme: A Programming Environment for Scheme") ".")))) "DrScheme: A Programming Environment for Scheme") "."))))))

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

@ -5,7 +5,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "External Resources")) (head ,hd-css ,@hd-links (title "External Resources"))
(body (body
@ -29,4 +31,4 @@
"many Scheme resources, including books, implementations, " "many Scheme resources, including books, implementations, "
"and libraries: " "and libraries: "
(a ([href "http://www.schemers.org/"] [target "_top"]) (a ([href "http://www.schemers.org/"] [target "_top"])
"http://www.schemers.org/") ".")))) "http://www.schemers.org/") "."))))))

6
collects/help/servlets/resources/libext.ss
View File

@ -6,7 +6,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Libraries")) (head ,hd-css ,@hd-links (title "Libraries"))
(body (body
@ -30,4 +32,4 @@
"If you write a PLT library or extension, we would like to hear about" "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 " " it! Please send a message about it to Matthew Flatt at "
(TT "mflatt@cs.utah.edu") " so we can list it. " (TT "mflatt@cs.utah.edu") " so we can list it. "
"Thanks for your efforts!")))) "Thanks for your efforts!"))))))

6
collects/help/servlets/resources/maillist.ss
View File

@ -5,7 +5,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Mailing Lists")) (head ,hd-css ,@hd-links (title "Mailing Lists"))
(body (body
@ -79,4 +81,4 @@
(a ([href "mailto:plt-scheme-es-request@list.cs.brown.edu"]) (a ([href "mailto:plt-scheme-es-request@list.cs.brown.edu"])
"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. " " 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."))))))

6
collects/help/servlets/resources/teachscheme.ss
View File

@ -5,7 +5,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "TeachScheme! Workshops")) (head ,hd-css ,@hd-links (title "TeachScheme! Workshops"))
(body (body
@ -28,4 +30,4 @@
"For more information, see the " "For more information, see the "
(a ([href "http://www.teach-scheme.org/Workshops/"] (a ([href "http://www.teach-scheme.org/Workshops/"]
[TARGET "_top"]) [TARGET "_top"])
"TeachScheme! Workshops page") ".")))) "TeachScheme! Workshops page") "."))))))

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

@ -29,267 +29,268 @@ is stored in a module top-level and that's namespace-specific.
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
(let () send/finish
;; doc subcollection name -> boolean (lambda ()
(define (search-type->search-level st) (let ()
(let loop ([n 0] [lst (map car search-types)]) ;; doc subcollection name -> boolean
(when (null? lst) (raise 'bad-search-type)) (define (search-type->search-level st)
(if (string=? (car lst) st) n (loop (add1 n) (cdr lst))))) (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) (define search-responses #f)
;; from what I can tell, this variable doesn't work as intended. ;; 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. ;; I've left it in for now, but this whole file needs to be rewritten.
;; -robby ;; -robby
(define current-kind #f) (define current-kind #f)
(define last-header #f) (define last-header #f)
(define max-reached #f) (define max-reached #f)
(define (build-maxxed-out k) (define (build-maxxed-out k)
(lambda () (lambda ()
(unless max-reached (unless max-reached
(set! max-reached #t) (set! max-reached #t)
(set! search-responses (set! search-responses
(cons `(b ,(with-color (cons `(b ,(with-color
"red" "red"
(string-constant (string-constant
plt:hd:search-stopped-too-many-matches))) plt:hd:search-stopped-too-many-matches)))
search-responses))) search-responses)))
(k #f))) (k #f)))
(define (add-header s key) (define (add-header s key)
(unless max-reached (unless max-reached
(set! last-header s) (set! last-header s)
(set! search-responses (set! search-responses
(list* `(b ([style "font-family:Verdana,Helvetica,sans-serif"]) (list* `(b ([style "font-family:Verdana,Helvetica,sans-serif"])
,s) ,s)
`(br) `(br)
search-responses)))) search-responses))))
(define (set-current-kind! s key) (define (set-current-kind! s key)
(set! current-kind (cadr (assoc s kind-types)))) (set! current-kind (cadr (assoc s kind-types))))
(define exp-web-root (define exp-web-root
(explode-path (normalize-path (find-collects-dir)))) (explode-path (normalize-path (find-collects-dir))))
(define web-root-len (length exp-web-root)) (define web-root-len (length exp-web-root))
(define (keyword-string? ekey) (define (keyword-string? ekey)
(and (string? ekey) (and (string? ekey)
(not (string=? ekey "")))) (not (string=? ekey ""))))
(define (pretty-label label ekey) (define (pretty-label label ekey)
(if (keyword-string? ekey) (if (keyword-string? ekey)
`(font ([face "monospace"]) `(font ([face "monospace"])
;; boldface keyword occurrences ;; boldface keyword occurrences
,@(let ([mpos (regexp-match-positions (non-regexp ekey) label)]) ,@(let ([mpos (regexp-match-positions (non-regexp ekey) label)])
(if mpos (if mpos
(let* ([item (car mpos)] (let* ([item (car mpos)]
[start (car item)] [start (car item)]
[stop (cdr item)]) [stop (cdr item)])
(list (substring label 0 start) (list (substring label 0 start)
`(b ,(substring label start stop)) `(b ,(substring label start stop))
(substring label stop (string-length label)))) (substring label stop (string-length label))))
(list label)))) (list label))))
label)) label))
(define (maybe-extract-coll s) (define (maybe-extract-coll s)
(let ([len (string-length s)]) (let ([len (string-length s)])
(if (and (> len 17) (if (and (> len 17)
(string=? (substring s 0 4) "the ") (string=? (substring s 0 4) "the ")
(string=? (substring s (- len 11) len) " collection")) (string=? (substring s (- len 11) len) " collection"))
(substring s 4 (- len 11)) (substring s 4 (- len 11))
s))) s)))
(define no-anchor-format (define no-anchor-format
(string-append "/servlets/doc-anchor.ss?" (string-append "/servlets/doc-anchor.ss?"
"file=~a&" "file=~a&"
"caption=~a&" "caption=~a&"
"name=~a")) "name=~a"))
(define with-anchor-format (define with-anchor-format
(string-append no-anchor-format "&offset=~a#temp")) (string-append no-anchor-format "&offset=~a#temp"))
(define (make-caption coll) (define (make-caption coll)
(format "Documentation for the ~a collection" coll)) (format "Documentation for the ~a collection" coll))
(define (make-search-link href label src ekey) (define (make-search-link href label src ekey)
`(table ([cellspacing "0"] [cellpadding "0"]) `(table ([cellspacing "0"] [cellpadding "0"])
(tr (td (div ([align "left-outdent"]) (tr (td (div ([align "left-outdent"])
(a ([href ,href]) ,(pretty-label label ekey)) (a ([href ,href]) ,(pretty-label label ekey))
" in \"" ,src "\""))))) " in \"" ,src "\"")))))
;; doc-txt? : string -> boolean ;; doc-txt? : string -> boolean
(define (doc-txt? str) (regexp-match "doc\\.txt$" str)) (define (doc-txt? str) (regexp-match "doc\\.txt$" str))
(define (make-html-href page-label path) (define (make-html-href page-label path)
(let ([anchored-path (make-anchored-path page-label path)]) (let ([anchored-path (make-anchored-path page-label path)])
(cond [(servlet-path? path) anchored-path] (cond [(servlet-path? path) anchored-path]
[(doc-txt? (path->string path)) ; collection doc.txt [(doc-txt? (path->string path)) ; collection doc.txt
(let ([maybe-coll (maybe-extract-coll last-header)]) (let ([maybe-coll (maybe-extract-coll last-header)])
(format no-anchor-format (format no-anchor-format
(uri-encode anchored-path) (uri-encode anchored-path)
(uri-encode (make-caption maybe-coll)) (uri-encode (make-caption maybe-coll))
maybe-coll))] maybe-coll))]
[else ; manual, so have absolute path [else ; manual, so have absolute path
(get-help-url path page-label)]))) (get-help-url path page-label)])))
;; make-anchored-path : string path -> string ;; make-anchored-path : string path -> string
;; page-label is #f or a bytes that labels an HTML anchor ;; page-label is #f or a bytes that labels an HTML anchor
;; path is either an absolute pathname (possibly not normalized) ;; path is either an absolute pathname (possibly not normalized)
;; in the format of the native OS, or, in the case of Help Desk ;; in the format of the native OS, or, in the case of Help Desk
;; servlets, a forward-slashified path beginning with "/servlets/" ;; servlets, a forward-slashified path beginning with "/servlets/"
(define (make-anchored-path page-label path) (define (make-anchored-path page-label path)
(let ([normal-path (let ([normal-path
(if (servlet-path? path) (if (servlet-path? path)
path path
(normalize-path path))]) (normalize-path path))])
(if (and page-label (if (and page-label
(string? page-label) (string? page-label)
(not (or (string=? page-label "NO TAG") (not (or (string=? page-label "NO TAG")
(regexp-match "\\?|&" page-label)))) (regexp-match "\\?|&" page-label))))
(string-append (path->string normal-path) "#" page-label) (string-append (path->string normal-path) "#" page-label)
(path->string normal-path)))) (path->string normal-path))))
; path is absolute pathname ; path is absolute pathname
(define (make-text-href page-label path) (define (make-text-href page-label path)
(let* ([maybe-coll (maybe-extract-coll last-header)] (let* ([maybe-coll (maybe-extract-coll last-header)]
[hex-path (uri-encode (path->string (normalize-path path)))] [hex-path (uri-encode (path->string (normalize-path path)))]
[hex-caption (if (eq? maybe-coll last-header) [hex-caption (if (eq? maybe-coll last-header)
hex-path hex-path
(uri-encode (make-caption maybe-coll)))] (uri-encode (make-caption maybe-coll)))]
[offset (or (and (number? page-label) page-label) [offset (or (and (number? page-label) page-label)
0)]) 0)])
(format with-anchor-format (format with-anchor-format
hex-path hex-caption (uri-encode maybe-coll) offset))) hex-path hex-caption (uri-encode maybe-coll) offset)))
(define (html-entry? path) (define (html-entry? path)
(and (not (suffixed? path #"doc.txt")) (and (not (suffixed? path #"doc.txt"))
(or (eq? current-kind 'html) (suffixed? path #".html")))) (or (eq? current-kind 'html) (suffixed? path #".html"))))
(define (suffixed? path suffix) (define (suffixed? path suffix)
(let* ([path-bytes (path->bytes path)] (let* ([path-bytes (path->bytes path)]
[path-len (bytes-length path-bytes)] [path-len (bytes-length path-bytes)]
[suffix-len (bytes-length suffix)]) [suffix-len (bytes-length suffix)])
(and (path-len . >= . suffix-len) (and (path-len . >= . suffix-len)
(bytes=? (subbytes path-bytes (- path-len suffix-len) path-len) (bytes=? (subbytes path-bytes (- path-len suffix-len) path-len)
suffix)))) suffix))))
(define (goto-lucky-entry ekey label src path page-label key) (define (goto-lucky-entry ekey label src path page-label key)
(let ([href (if (html-entry? path) (let ([href (if (html-entry? path)
(make-html-href page-label path) (make-html-href page-label path)
(make-text-href page-label path))]) (make-text-href page-label path))])
(send/finish (redirect-to href)))) (send/finish (redirect-to href))))
(define (add-entry ekey label src path page-label key) (define (add-entry ekey label src path page-label key)
(let* ([entry (let* ([entry
(if (html-entry? path) (if (html-entry? path)
(make-search-link (make-html-href page-label path) (make-search-link (make-html-href page-label path)
label src ekey) label src ekey)
(make-search-link (make-text-href page-label path) (make-search-link (make-text-href page-label path)
label src ekey))]) label src ekey))])
(set! search-responses (cons entry search-responses)))) (set! search-responses (cons entry search-responses))))
(define (make-results-page search-string lang-name items regexp? exact?) (define (make-results-page search-string lang-name items regexp? exact?)
(let-values ([(string-finds finds) (let-values ([(string-finds finds)
(build-string-finds/finds search-string regexp? exact?)]) (build-string-finds/finds search-string regexp? exact?)])
`(html `(html
(head ,hd-css ,@hd-links (title "PLT Help Desk search results")) (head ,hd-css ,@hd-links (title "PLT Help Desk search results"))
(body (body
(h1 "Search Results") (h1 "Search Results")
(h2 (h2
,@(if lang-name ,@(if lang-name
(list "Language: " (with-color "firebrick" lang-name) '(br)) (list "Language: " (with-color "firebrick" lang-name) '(br))
'()) '())
,@(let ([single-key ,@(let ([single-key
(lambda (sf) (lambda (sf)
(with-color "firebrick" (format " \"~a\"" sf)))]) (with-color "firebrick" (format " \"~a\"" sf)))])
(cond [(null? string-finds) '()] (cond [(null? string-finds) '()]
[(null? (cdr string-finds)) [(null? (cdr string-finds))
(list "Key: " (single-key (car string-finds)))] (list "Key: " (single-key (car string-finds)))]
[else [else
(cons "Keys: " (map single-key string-finds))]))) (cons "Keys: " (map single-key string-finds))])))
(br) (br)
,@items)))) ,@items))))
(define (search-results lucky? search-string search-type match-type (define (search-results lucky? search-string search-type match-type
manuals doc-txt? lang-name) manuals doc-txt? lang-name)
(set! search-responses '()) (set! search-responses '())
(set! max-reached #f) (set! max-reached #f)
(let* ([search-level (search-type->search-level search-type)] (let* ([search-level (search-type->search-level search-type)]
[regexp? (string=? match-type "regexp-match")] [regexp? (string=? match-type "regexp-match")]
[exact-match? (string=? match-type "exact-match")] [exact-match? (string=? match-type "exact-match")]
[key (gensym)] [key (gensym)]
[result (let/ec k [result (let/ec k
(do-search search-string (do-search search-string
search-level search-level
regexp? regexp?
exact-match? exact-match?
manuals manuals
doc-txt? doc-txt?
key key
(build-maxxed-out k) (build-maxxed-out k)
add-header add-header
set-current-kind! set-current-kind!
(if lucky? goto-lucky-entry add-entry)))] (if lucky? goto-lucky-entry add-entry)))]
[html (make-results-page [html (make-results-page
search-string search-string
lang-name lang-name
(if (string? result) ; error message (if (string? result) ; error message
`((h2 ([style "color:red"]) ,result)) `((h2 ([style "color:red"]) ,result))
(reverse search-responses)) (reverse search-responses))
regexp? regexp?
exact-match?)]) exact-match?)])
html)) html))
(define empty-search-page (define empty-search-page
`(html (head (title "Empty search string in PLT Help Desk")) `(html (head (title "Empty search string in PLT Help Desk"))
(body (h2 "Empty search string")))) (body (h2 "Empty search string"))))
(define (lucky-search? bindings) (define (lucky-search? bindings)
(with-handlers ([exn:fail? (lambda _ #f)]) (with-handlers ([exn:fail? (lambda _ #f)])
(let ([result (extract-binding/single 'lucky bindings)]) (let ([result (extract-binding/single 'lucky bindings)])
(not (string=? result "false"))))) (not (string=? result "false")))))
(define (maybe-update-box b s) (define (maybe-update-box b s)
(unless (string=? s "") (set-box! b s))) (unless (string=? s "") (set-box! b s)))
(define (convert-manuals manuals) (define (convert-manuals manuals)
(if manuals (if manuals
(let ([parsed (read-from-string manuals)]) (let ([parsed (read-from-string manuals)])
(if (and (list? parsed) (andmap bytes? parsed)) (if (and (list? parsed) (andmap bytes? parsed))
(map bytes->path parsed) (map bytes->path parsed)
(map car (find-doc-names)))) (map car (find-doc-names))))
(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)))])))))
(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)))])))))))

6
collects/help/servlets/scheme/doc.ss
View File

@ -8,7 +8,9 @@
(define (start initial-request) (define (start initial-request)
(define (make-header-text s) (define (make-header-text s)
(color-highlight `(h2 () ,s))) (color-highlight `(h2 () ,s)))
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Documentation")) (head ,hd-css ,@hd-links (title "Documentation"))
(body (body
@ -41,4 +43,4 @@
(a ([href "/servlets/howtouse.ss#search"]) "Searching") (a ([href "/servlets/howtouse.ss#search"]) "Searching")
" in Help Desk finds documenation from all sources, including " " in Help Desk finds documenation from all sources, including "
(a ([href "/servlets/howtodrscheme.ss"]) "DrScheme") (a ([href "/servlets/howtodrscheme.ss"]) "DrScheme")
" and the language and library documentation.")))) " and the language and library documentation."))))))

6
collects/help/servlets/scheme/how.ss
View File

@ -10,7 +10,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
(send/finish (send/finish
`(html `(html
(head ,hd-css ,@hd-links (title "Software & Components")) (head ,hd-css ,@hd-links (title "Software & Components"))
@ -112,4 +114,4 @@
(a ((name "installed-components"))) (a ((name "installed-components")))
(i "The list below was generated by searching the set of installed" (i "The list below was generated by searching the set of installed"
" libraries.") " libraries.")
(ul ,@(help-desk:installed-components))))))) (ul ,@(help-desk:installed-components)))))))))

6
collects/help/servlets/scheme/langlevels.ss
View File

@ -6,7 +6,9 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "A Note on Language Levels")) (head ,hd-css ,@hd-links (title "A Note on Language Levels"))
(body (body
@ -57,4 +59,4 @@
"Please follow the links on this page for more information. If you" "Please follow the links on this page for more information. If you"
" have additional questions or comments, please contact us at " " have additional questions or comments, please contact us at "
(a ((href "mailto:scheme@plt-scheme.org")) "scheme@plt-scheme.org") (a ((href "mailto:scheme@plt-scheme.org")) "scheme@plt-scheme.org")
".")))) "."))))))

24
collects/help/servlets/scheme/misc.ss
View File

@ -23,14 +23,16 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme")) send/finish
(body (lambda ()
(h1 "How to do things in Scheme") `(html (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme"))
(ul ,@(map make-link-line links)) (body
(p) (h1 "How to do things in Scheme")
"If you did't find what you're looking for in the list above, try " (ul ,@(map make-link-line links))
(a ((href "/servlets/howtouse.ss#search")) "searching") (p)
" in Help Desk. Also, check " "If you did't find what you're looking for in the list above, try "
(a ((href "http://www.htus.org/")) (i "How to Use Scheme")) (a ((href "/servlets/howtouse.ss#search")) "searching")
".")))) " in Help Desk. Also, check "
(a ((href "http://www.htus.org/")) (i "How to Use Scheme"))
"."))))))

7
collects/help/servlets/scheme/misc/activex.ss
View File

@ -8,8 +8,9 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(HTML `(HTML
(HEAD ,hd-css (HEAD ,hd-css
,@hd-links ,@hd-links
@ -26,4 +27,4 @@
(TARGET "_top")) "http://www.plt-scheme.org/software/mysterx/")) (TARGET "_top")) "http://www.plt-scheme.org/software/mysterx/"))
(P) (P)
,(collection-doc-link "mysterx" ,(collection-doc-link "mysterx"
"The MysterX collection"))))) "The MysterX collection")))))))

8
collects/help/servlets/scheme/misc/batch.ss
View File

@ -8,9 +8,9 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(with-errors-to-browser
(report-errors-to-browser send/finish) send/finish
(lambda ()
`(HTML `(HTML
(HEAD ,hd-css (HEAD ,hd-css
,@hd-links ,@hd-links
@ -49,4 +49,4 @@
"lines beginning with semicolons as comments, and runs the " "lines beginning with semicolons as comments, and runs the "
"Scheme code. When the Scheme program is " "Scheme code. When the Scheme program is "
"done, control returns to the batch file, and the " "done, control returns to the batch file, and the "
(TT "goto") " jumps around the Scheme code.")))) (TT "goto") " jumps around the Scheme code."))))))

284
collects/help/servlets/scheme/misc/cgi.ss
View File

@ -7,147 +7,147 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(with-errors-to-browser
(report-errors-to-browser send/finish) send/finish
(lambda ()
`(HTML `(HTML
(HEAD ,hd-css (HEAD ,hd-css
,@hd-links ,@hd-links
(TITLE "How to write CGI scripts")) (TITLE "How to write CGI scripts"))
(BODY (BODY
(H1 "How to write CGI scripts") (H1 "How to write CGI scripts")
(A ((NAME "cgi") (VALUE "CGI scripts"))) (A ((NAME "cgi") (VALUE "CGI scripts")))
"Type " (TT "CGI") " in the " (B "Search for") " " "Type " (TT "CGI") " in the " (B "Search for") " "
"field in Help Desk and click on the " "field in Help Desk and click on the "
(B (TT "Search")) " button to get information " (B (TT "Search")) " button to get information "
"on CGI-related functions." "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") "."
(P) (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) (P)
"Let's write a simple \"finger server\" in MzScheme. " "MzScheme comes with a CGI library that is designed to "
"The front-end will be a Web form that accepts a username. " "make it easy to write such scripts. In the mini-tutorial "
"The form should supply a username in the field `name'. " "below, we'll walk you through the "
"The CGI script fingers that user." "construction of such a script. If you have questions or "
(P) "comments, send email to "
"First, make sure you have MzScheme installed on the host " (A ((HREF "mailto:sk@plt-scheme.org"))
"where your Web server is located." "sk@plt-scheme.org") "."
(P) (P)
"A CGI script must be an executable. Each OS has different " (HR)
"ways of launching an application. Under Unix, it's " (P)
"probably easiest to make them simple shell scripts. " "Let's write a simple \"finger server\" in MzScheme. "
"Therefore, place the following magic incantation at the " "The front-end will be a Web form that accepts a username. "
"top of your script:" "The form should supply a username in the field `name'. "
(P) "The CGI script fingers that user."
(PRE (P)
" #!/bin/sh" (BR) "First, make sure you have MzScheme installed on the host "
" string=? ; exec /usr/local/bin/mzscheme -r $0 \"$@\"") "where your Web server is located."
(P) (P)
"Make sure the path to MzScheme is specified correctly." "A CGI script must be an executable. Each OS has different "
(P) "ways of launching an application. Under Unix, it's "
"Now we're in Scheme-land. First, let's load the Scheme " "probably easiest to make them simple shell scripts. "
"CGI library and define where `finger' resides." "Therefore, place the following magic incantation at the "
(P) "top of your script:"
(PRE (P)
" (require (lib \"cgi.ss\" \"net\"))" (BR) (PRE
" (define finger-program \"/usr/bin/finger\")") " #!/bin/sh" (BR)
(P) " string=? ; exec /usr/local/bin/mzscheme -r $0 \"$@\"")
"Next we must get the names bound by the form, and " (P)
"extract the username field." "Make sure the path to MzScheme is specified correctly."
(P) (P)
(PRE "Now we're in Scheme-land. First, let's load the Scheme "
" (let ((bindings (get-bindings)))" (BR) "CGI library and define where `finger' resides."
" (let ((name (extract-binding/single 'name bindings)))") (P)
(P) (PRE
"We use extract-binding/single to make sure only one name " " (require (lib \"cgi.ss\" \"net\"))" (BR)
"field was bound. (You can bind the same field multiple " " (define finger-program \"/usr/bin/finger\")")
"times using check-boxes. This is just one kind of " (P)
"error-checking; a robust CGI script will do more." "Next we must get the names bound by the form, and "
(P) "extract the username field."
"Next we invoke the finger program using `process*'. " (P)
"If no username was specified, we just run finger on the host." (PRE
(P) " (let ((bindings (get-bindings)))" (BR)
(PRE " (let ((name (extract-binding/single 'name bindings)))")
" (let ((results (if (string=? name \"\"))" (BR) (P)
" (process* finger-program)" (BR) "We use extract-binding/single to make sure only one name "
" (process* finger-program name))))") "field was bound. (You can bind the same field multiple "
(P) "times using check-boxes. This is just one kind of "
"The `process*' function returns a list of several values. " "error-checking; a robust CGI script will do more."
"The first of these is the output port. Let's pull this " (P)
"out and name it." "Next we invoke the finger program using `process*'. "
(P) "If no username was specified, we just run finger on the host."
(PRE (P)
" (let ((proc->self (car results)))") (PRE
(P) " (let ((results (if (string=? name \"\"))" (BR)
"Now we extract the output of running finger into a " " (process* finger-program)" (BR)
"list of strings." " (process* finger-program name))))")
(P) (P)
(PRE "The `process*' function returns a list of several values. "
" (let ((strings (let loop " (BR) "The first of these is the output port. Let's pull this "
" (let ((l (read-line proc->self)))" (BR) "out and name it."
" (if (eof-object? l)" (BR) (P)
" null" (BR) (PRE
" (cons l (loop))))))))") " (let ((proc->self (car results)))")
(P) (P)
"All that's left is to print this out to the user. " "Now we extract the output of running finger into a "
"We use the `generate-html-output' procedure to do that, " "list of strings."
"which takes care of generating the appropriate MIME header " (P)
"(as required of CGI scripts). " (PRE
"Note that the <PRE> tag of HTML doesn't prevent its " " (let ((strings (let loop " (BR)
"contents from being processed. To avoid this " " (let ((l (read-line proc->self)))" (BR)
"(i.e., to generate truly verbatim output), " " (if (eof-object? l)" (BR)
"we use `string->html', which knows about HTML quoting " " null" (BR)
"conventions." " (cons l (loop))))))))")
(P) (P)
(PRE "All that's left is to print this out to the user. "
" (generate-html-output \"Finger Gateway Output\"" (BR) "We use the `generate-html-output' procedure to do that, "
" (append " (BR) "which takes care of generating the appropriate MIME header "
" '(\"<PRE>\")" (BR) "(as required of CGI scripts). "
" (map string->html strings)" (BR) "Note that the <PRE> tag of HTML doesn't prevent its "
" '(\"</PRE>\"))))))))") "contents from being processed. To avoid this "
(P) "(i.e., to generate truly verbatim output), "
"That's all! This program will work irrespective of " "we use `string->html', which knows about HTML quoting "
"whether the form uses a GET or POST method to send its " "conventions."
"data over, which gives designers additional flexibility " (P)
"(GET provides a weak form of persistence, while " (PRE
"POST is more robust and better suited to large volumes of " " (generate-html-output \"Finger Gateway Output\"" (BR)
"data)." " (append " (BR)
(P) " '(\"<PRE>\")" (BR)
"Here's the entire program, once again:" " (map string->html strings)" (BR)
(P) " '(\"</PRE>\"))))))))")
(PRE (P)
" #!/bin/sh" (BR) "That's all! This program will work irrespective of "
" string=? ; exec /usr/local/bin/mzscheme -r $0 "$@"" (BR) "whether the form uses a GET or POST method to send its "
"" (BR) "data over, which gives designers additional flexibility "
" (require (lib \"cgi.ss\" \"net\"))" (BR) "(GET provides a weak form of persistence, while "
" (define finger-program \"/usr/bin/finger\")" (BR) "POST is more robust and better suited to large volumes of "
"" (BR) "data)."
" (let ((bindings (get-bindings)))" (BR) (P)
" (let ((name (extract-binding/single 'name bindings)))" (BR) "Here's the entire program, once again:"
" (let ((results (if (string=? name "")" (BR) (P)
" (process* finger-program)" (BR) (PRE
" (process* finger-program name))))" (BR) " #!/bin/sh" (BR)
" (let ((proc->self (car results)))" (BR) " string=? ; exec /usr/local/bin/mzscheme -r $0 "$@"" (BR)
" (let ((strings (let loop " (BR) "" (BR)
" (let ((l (read-line proc->self)))" (BR) " (require (lib \"cgi.ss\" \"net\"))" (BR)
" (if (eof-object? l)" (BR) " (define finger-program \"/usr/bin/finger\")" (BR)
" null" (BR) "" (BR)
" (cons l (loop)))))))" (BR) " (let ((bindings (get-bindings)))" (BR)
" (generate-html-output \"Finger Gateway Output\"" (BR) " (let ((name (extract-binding/single 'name bindings)))" (BR)
" (append" (BR) " (let ((results (if (string=? name "")" (BR)
" '(\"<PRE>\")" (BR) " (process* finger-program)" (BR)
" (map string->html strings)" (BR) " (process* finger-program name))))" (BR)
" '(\"</PRE>\"))))))))"))))) " (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)
" '(\"<PRE>\")" (BR)
" (map string->html strings)" (BR)
" '(\"</PRE>\"))))))))")))))))

49
collects/help/servlets/scheme/misc/database.ss
View File

@ -8,27 +8,28 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
`(HTML (lambda ()
(HEAD ,hd-css `(HTML
,@hd-links (HEAD ,hd-css
(TITLE "How to connect to databases")) ,@hd-links
(BODY (TITLE "How to connect to databases"))
(H1 "How to connect to databases") (BODY
(A ((NAME "db") (VALUE "Database connections"))) (H1 "How to connect to databases")
"SrPersist (\"Sister Persist\") is an ODBC interface for " (A ((NAME "db") (VALUE "Database connections")))
"DrScheme and MzScheme. " "SrPersist (\"Sister Persist\") is an ODBC interface for "
"Download SrPersist from " "DrScheme and MzScheme. "
(PRE "Download SrPersist from "
" " (PRE
(A ((HREF "http://www.plt-scheme.org/software/srpersist/") " "
(TARGET "_top")) "http://www.plt-scheme.org/software/srpersist/") ". ") (A ((HREF "http://www.plt-scheme.org/software/srpersist/")
"ODBC is a very low-level interface. " (TARGET "_top")) "http://www.plt-scheme.org/software/srpersist/") ". ")
"Francisco Solsona has built a higher-level interface, " "ODBC is a very low-level interface. "
"SchemeQL, that uses SrPersist. See " "Francisco Solsona has built a higher-level interface, "
(PRE "SchemeQL, that uses SrPersist. See "
" " (PRE
(A ((HREF "http://schematics.sourceforge.net/schemeql.html") " "
(TARGET "_top")) "http://schematics.sourceforge.net/schemeql.html")) (A ((HREF "http://schematics.sourceforge.net/schemeql.html")
" for more details.")))) (TARGET "_top")) "http://schematics.sourceforge.net/schemeql.html"))
" for more details."))))))

48
collects/help/servlets/scheme/misc/graphics.ss
View File

@ -9,27 +9,27 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(with-errors-to-browser
(report-errors-to-browser send/finish) send/finish
(lambda ()
`(HTML `(HTML
(HEAD ,hd-css (HEAD ,hd-css
,@hd-links ,@hd-links
(TITLE "How to write graphics programs")) (TITLE "How to write graphics programs"))
(BODY (BODY
(H1 "How to write graphics programs") (H1 "How to write graphics programs")
(A ((NAME "gfx") (VALUE "Graphics"))) (A ((NAME "gfx") (VALUE "Graphics")))
(A ((NAME "gui") (VALUE "GUIs"))) (A ((NAME "gui") (VALUE "GUIs")))
(A ((NAME "gui2") (VALUE "Graphical User Interfaces"))) (A ((NAME "gui2") (VALUE "Graphical User Interfaces")))
"To write graphics programs, use DrScheme with the " "To write graphics programs, use DrScheme with the "
"Graphical (MrEd) flavor of the PLT " "Graphical (MrEd) flavor of the PLT "
(A ((HREF "/servlets/scheme/what.ss")) " language") ". " (A ((HREF "/servlets/scheme/what.ss")) " language") ". "
"MrEd provides a complete GUI toolbox that is described " "MrEd provides a complete GUI toolbox that is described "
"in " "in "
,(main-manual-page "mred") ". " ,(main-manual-page "mred") ". "
(P) (P)
"For simple graphics programs, you may also use the " "For simple graphics programs, you may also use the "
"viewport-based graphics library, which is described in " "viewport-based graphics library, which is described in "
,(manual-entry "misclib" "viewport" "Viewport Graphics") ". " ,(manual-entry "misclib" "viewport" "Viewport Graphics") ". "
"The following declaration loads viewport graphics into MrEd:" "The following declaration loads viewport graphics into MrEd:"
(PRE " (require (lib \"graphics.ss\" \"graphics\"))"))))) (PRE " (require (lib \"graphics.ss\" \"graphics\"))")))))))

78
collects/help/servlets/scheme/misc/script.ss
View File

@ -8,42 +8,42 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(with-errors-to-browser
(report-errors-to-browser send/finish) send/finish
(lambda ()
`(HTML `(HTML
(HEAD ,hd-css (HEAD ,hd-css
,@hd-links ,@hd-links
(TITLE "How to write Unix shell scripts")) (TITLE "How to write Unix shell scripts"))
(BODY (BODY
(H1 "How to write Unix shell scripts") (H1 "How to write Unix shell scripts")
(A ((NAME "sh") (VALUE "Shell scripts"))) (A ((NAME "sh") (VALUE "Shell scripts")))
"When MzScheme is installed as part of the standard Unix " "When MzScheme is installed as part of the standard Unix "
"PLT distribution, " "PLT distribution, "
(TT "plt/bin/mzscheme") " and " (TT "plt/bin/mzscheme") " and "
(TT "plt/bin/mred") " are binary executables." (TT "plt/bin/mred") " are binary executables."
(P) (P)
"Thus, they can be used with Unix's " (TT "#!") "Thus, they can be used with Unix's " (TT "#!")
" convention as follows:" " convention as follows:"
(PRE (PRE
" #! /usr/local/lib/plt/bin/mzscheme -r ... " (BR) " #! /usr/local/lib/plt/bin/mzscheme -r ... " (BR)
" " (I "scheme-program") " ...") " " (I "scheme-program") " ...")
"assuming that the " (TT "plt") " tree is installed as " "assuming that the " (TT "plt") " tree is installed as "
(TT "/usr/local/lib/plt") ". " (TT "/usr/local/lib/plt") ". "
"To avoid specifying an absolute path, use " "To avoid specifying an absolute path, use "
(TT "/usr/bin/env") ":" (TT "/usr/bin/env") ":"
(PRE (PRE
" #! /usr/bin/env mzscheme -r ... " (BR) " #! /usr/bin/env mzscheme -r ... " (BR)
" " (I "scheme-program") " ...") " " (I "scheme-program") " ...")
(P) (P)
"The above works when " "The above works when "
(TT "mzscheme") (TT "mzscheme")
" is in the user's path. " " is in the user's path. "
"The " (TT "mred") " executable can be used in the " "The " (TT "mred") " executable can be used in the "
"same way for GUI scripts." "same way for GUI scripts."
(P) (P)
"Within " (I "scheme-program") ", " "Within " (I "scheme-program") ", "
(TT "(current-command-line-arguments)") (TT "(current-command-line-arguments)")
" produces a vector of strings for the arguments " " produces a vector of strings for the arguments "
"passed to the script. The vector is also available as " "passed to the script. The vector is also available as "
(TT "argv") ".")))) (TT "argv") "."))))))

44
collects/help/servlets/scheme/misc/standalone.ss
View File

@ -9,26 +9,26 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(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."
(report-errors-to-browser send/finish) (p)
"The mzc compiler provides a more low-level interface "
`(HTML "to stand-alone executables creation. "
(HEAD ,hd-css "See "
,@hd-links ,(main-manual-page "mzc")
(TITLE "How to build a stand-alone executable")) " for more information."))))))
(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."))))

30
collects/help/servlets/scheme/misc/system.ss
View File

@ -9,18 +9,18 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(with-errors-to-browser
(report-errors-to-browser send/finish) send/finish
(lambda ()
`(HTML `(HTML
(HEAD ,hd-css (HEAD ,hd-css
,@hd-links ,@hd-links
(TITLE "How to call low-level system routines")) (TITLE "How to call low-level system routines"))
(BODY (BODY
(H1 "How to call low-level system routines") (H1 "How to call low-level system routines")
(A ((NAME "os") (VALUE "Low-level operating system calls"))) (A ((NAME "os") (VALUE "Low-level operating system calls")))
"To call low-level system routines, you must write " "To call low-level system routines, you must write "
"an extension to MzScheme using the C programming language. " "an extension to MzScheme using the C programming language. "
"See " "See "
,(main-manual-page "insidemz") ,(main-manual-page "insidemz")
" for details.")))) " for details."))))))

186
collects/help/servlets/scheme/what.ss
View File

@ -9,95 +9,97 @@
(define (standout-text s) (define (standout-text s)
(with-color "forestgreen" `(B ,s))) (with-color "forestgreen" `(B ,s)))
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html send/finish
(head ,hd-css ,@hd-links (title "Scheme Languages")) (lambda ()
(body `(html
(h1 "Scheme Languages") (head ,hd-css ,@hd-links (title "Scheme Languages"))
(a ([name "scheme"] [value "Language Family"])) (body
(a ([name "r5rs"] [value "r5rs"])) (h1 "Scheme Languages")
(a ([name "language levels"] [value "language levels"])) (a ([name "scheme"] [value "Language Family"]))
"From the introduction of " ,(main-manual-page "r5rs") " (R5RS):" (a ([name "r5rs"] [value "r5rs"]))
(p) (a ([name "language levels"] [value "language levels"]))
(dl (dd "Scheme is a statically scoped and properly tail-recursive" "From the introduction of " ,(main-manual-page "r5rs") " (R5RS):"
" dialect of the Lisp programming language [...] designed to" (p)
" have an exceptionally clear and simple semantics and few" (dl (dd "Scheme is a statically scoped and properly tail-recursive"
" different ways to form expressions. A wide variety of" " dialect of the Lisp programming language [...] designed to"
" programming paradigms, including imperative, functional, and" " have an exceptionally clear and simple semantics and few"
" message passing styles, find convenient expression in" " different ways to form expressions. A wide variety of"
" Scheme.")) " programming paradigms, including imperative, functional, and"
(p) " message passing styles, find convenient expression in"
"DrScheme supports many dialects of Scheme. The following dialects are" " Scheme."))
" specifically designed for teaching computer science. In DrScheme's " (p)
(a ([href "/servlets/scheme/what.ss#lang-sel"]) "DrScheme supports many dialects of Scheme. The following dialects are"
"language selection menu") " specifically designed for teaching computer science. In DrScheme's "
", they are found under the heading " (b "How to Design Programs") "." (a ([href "/servlets/scheme/what.ss#lang-sel"])
(ul (li (a ([name "beg"] [value "Beginning Student language"])) "language selection menu")
,(standout-text "Beginning Student") ", they are found under the heading " (b "How to Design Programs") "."
" is a pedagogical version of Scheme that is tailored for" (ul (li (a ([name "beg"] [value "Beginning Student language"]))
" beginning computer science students.") ,(standout-text "Beginning Student")
(li (a ([name "begla"] " is a pedagogical version of Scheme that is tailored for"
[value "Beginning Student with List Abbreviations language"])) " beginning computer science students.")
,(standout-text "Beginning Student with List Abbreviations") (li (a ([name "begla"]
" extends Beginning Student with convenient (but potentially" [value "Beginning Student with List Abbreviations language"]))
" confusing) ways to write lists, including quasiquote.") ,(standout-text "Beginning Student with List Abbreviations")
(li (a ([name "int"] [value "Intermediate Student language"])) " extends Beginning Student with convenient (but potentially"
,(standout-text "Intermediate Student") " confusing) ways to write lists, including quasiquote.")
" adds local bindings and higher-order functions.") (li (a ([name "int"] [value "Intermediate Student language"]))
(li (a ([name "intlam"] ,(standout-text "Intermediate Student")
[value "Intermediate Student with Lambda language"])) " adds local bindings and higher-order functions.")
,(standout-text "Intermediate Student with Lambda") (li (a ([name "intlam"]
" adds anonymous functions.") [value "Intermediate Student with Lambda language"]))
(li (a ([name "adv"] [value "Advanced Student language"])) ,(standout-text "Intermediate Student with Lambda")
,(standout-text "Advanced Student") " adds anonymous functions.")
" adds mutable state.")) (li (a ([name "adv"] [value "Advanced Student language"]))
"The " ,(standout-text "Advanced Student")
,(standout-text "Essentials of Programming Languages") " adds mutable state."))
" language is designed for use with the MIT Press textbook with that" "The "
" name." ,(standout-text "Essentials of Programming Languages")
(p) " language is designed for use with the MIT Press textbook with that"
"Other dialects are designed for practicing programmers. The " " name."
(a ([name "r5rs2"] [value "R5RS Scheme language"])) (p)
,(standout-text "R5RS") "Other dialects are designed for practicing programmers. The "
" language is a standard dialect of Scheme that is defined by the " (a ([name "r5rs2"] [value "R5RS Scheme language"]))
,(main-manual-page "r5rs") ". " ,(standout-text "R5RS")
(a ([name "full"] [value "PLT Scheme language"])) " language is a standard dialect of Scheme that is defined by the "
"In DrScheme's " ,(main-manual-page "r5rs") ". "
(a ([href "/servlets/scheme/what.ss#lang-sel"]) (a ([name "full"] [value "PLT Scheme language"]))
"language selection menu") "In DrScheme's "
", the following languages are found under the heading " (b "PLT") ":" (a ([href "/servlets/scheme/what.ss#lang-sel"])
(ul (li ,(standout-text "Textual (MzScheme)") " is a superset of R5RS" "language selection menu")
" Scheme. In addition to the the base Scheme language, PLT" ", the following languages are found under the heading " (b "PLT") ":"
" Scheme provides exceptions, threads, objects, modules," (ul (li ,(standout-text "Textual (MzScheme)") " is a superset of R5RS"
" components, regular expressions, TCP support, filesystem" " Scheme. In addition to the the base Scheme language, PLT"
" utilities, and process control operations. This language is" " Scheme provides exceptions, threads, objects, modules,"
" defined in " ,(main-manual-page "mzscheme") ". ") " components, regular expressions, TCP support, filesystem"
(li ,(standout-text "Graphical (MrEd)") " includes the " " utilities, and process control operations. This language is"
(standout-text "Textual (MzScheme)") " language and adds a" " defined in " ,(main-manual-page "mzscheme") ". ")
" graphical toolbox, described in " (li ,(standout-text "Graphical (MrEd)") " includes the "
,(main-manual-page "mred") ".") (standout-text "Textual (MzScheme)") " language and adds a"
(li ,(standout-text "Pretty Big") " is a superset of the " " graphical toolbox, described in "
(standout-text "Graphical (MrEd)") ,(main-manual-page "mred") ".")
" language, and adds forms from the " (li ,(standout-text "Pretty Big") " is a superset of the "
(standout-text "Pretty Big") " language. For those forms that" (standout-text "Graphical (MrEd)")
" are in both languages, Pretty Big behaves like Graphical" " language, and adds forms from the "
" (MrEd).")) (standout-text "Pretty Big") " language. For those forms that"
"The " (a ([name "module"] [value "module"])) " are in both languages, Pretty Big behaves like Graphical"
,(standout-text "(module ...)") " (MrEd)."))
" language supports development using PLT Scheme's " "The " (a ([name "module"] [value "module"]))
,(manual-entry "mzscheme" "modules" `(code "module")) ,(standout-text "(module ...)")
" form, where the module's language is explicitly declared in the code." " language supports development using PLT Scheme's "
(p) ,(manual-entry "mzscheme" "modules" `(code "module"))
"See " ,(manual-entry "drscheme" "language levels" "the DrScheme manual") " form, where the module's language is explicitly declared in the code."
" for further details on the languages, especially the teaching" (p)
" languages." "See " ,(manual-entry "drscheme" "language levels" "the DrScheme manual")
(p) " for further details on the languages, especially the teaching"
"DrScheme's set of languages can be extended, so the above list" " languages."
" mentions only the languages installed by default. Documentation for" (p)
" all languages is available through the " "DrScheme's set of languages can be extended, so the above list"
(a ([href "/servlets/manuals.ss"]) "manuals page") "." " mentions only the languages installed by default. Documentation for"
(p) " all languages is available through the "
(a ([name "lang-sel"] [value "language, setting"])) (a ([href "/servlets/manuals.ss"]) "manuals page") "."
"To change the" (p)
" language, select the " (b "Choose Language...") " item in the " (a ([name "lang-sel"] [value "language, setting"]))
(B "Language") " menu.")))) "To change the"
" language, select the " (b "Choose Language...") " item in the "
(B "Language") " menu."))))))

18
collects/help/servlets/teachpacks.ss
View File

@ -7,11 +7,13 @@
(define interface-version 'v1) (define interface-version 'v1)
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
`(html send/finish
(head (title "Teachpacks")) (lambda ()
(body (h1 "Teachpacks") `(html
(ul (li (b (a ([href ,(get-manual-index "teachpack")]) (head (title "Teachpacks"))
"Teachpacks for \"How to Design Programs\""))) (body (h1 "Teachpacks")
(li (b (a ([href ,(get-manual-index "teachpack-htdc")]) (ul (li (b (a ([href ,(get-manual-index "teachpack")])
"Teachpacks for \"How to Design Classes\"")))))))) "Teachpacks for \"How to Design Programs\"")))
(li (b (a ([href ,(get-manual-index "teachpack-htdc")])
"Teachpacks for \"How to Design Classes\""))))))))))

19
collects/htdp/servlet.ss
View File

@ -3,12 +3,23 @@
(require (lib "servlet-env.ss" "web-server" "tools") (require (lib "servlet-env.ss" "web-server" "tools")
(lib "error.ss" "htdp") (lib "error.ss" "htdp")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
(lib "list.ss") (lib "etc.ss"))
(lib "prim.ss" "lang") (provide (all-from (lib "servlet-env.ss" "web-server" "tools"))
(lib "unitsig.ss"))
(provide (all-from-except (lib "servlet-env.ss" "web-server" "tools") build-suspender)
(rename wrapped-build-suspender build-suspender)) (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 (define wrapped-build-suspender
(case-lambda (case-lambda
[(title content) [(title content)

14
collects/web-server/default-web-root/servlets/examples/compound/helper.ss
View File

@ -11,11 +11,13 @@
'n 'n
(request-bindings (request-bindings
(send/suspend (send/suspend
(let ([prompt (string-append "Enter " which-number ": ")]) (lambda (k-url)
(build-suspender (let ([prompt (string-append "Enter " which-number ": ")])
(list prompt) `(html (head (title ,prompt))
`(,@error-message (body (form ([action ,k-url]
(p ,prompt (input ([type "text"] [name "n"]))) [method "post"])
(input ([type "submit"] [value "Okay"]))))))))] ,@error-message
(p ,prompt (input ([type "text"] [name "n"])))
(input ([type "submit"] [value "Okay"]))))))))))]
[n (string->number n-str)]) [n (string->number n-str)])
(or n (ask `((p (font ([color "red"]) ,n-str) " is not a number. Please enter a number.")))))))) (or n (ask `((p (font ([color "red"]) ,n-str) " is not a number. Please enter a number."))))))))

24
collects/web-server/default-web-root/servlets/examples/compound/multiply.ss
View File

@ -47,18 +47,18 @@
(define (get-matrix-bindings rows columns) (define (get-matrix-bindings rows columns)
(request-bindings (request-bindings
(send/suspend (send/suspend
(build-suspender (lambda (k-url)
(list "Enter a " (number->string rows) " by " `(html (head (title "Enter a " ,(number->string rows) " by "
(number->string columns) " Matrix") ,(number->string columns) " Matrix"))
`((table (body (form ([action ,k-url] [method "post"])
. ,(build-list (table ,(build-list
rows rows
(lambda (r) (lambda (r)
`(tr . ,(build-list `(tr . ,(build-list
columns columns
(lambda (c) (lambda (c)
`(td (input ([type "text"] [name ,(field-name r c)]))))))))) `(td (input ([type "text"] [name ,(field-name r c)])))))))))
(input ([type "submit"] [name "submit"] [value "Okay"]))))))) (input ([type "submit"] [name "submit"] [value "Okay"])))))))))
; field-name : nat nat -> str ; field-name : nat nat -> str
(define (field-name row column) (define (field-name row column)

21
collects/web-server/default-web-root/servlets/tests/cut-module.ss
View File

@ -13,9 +13,11 @@
'order 'order
(request-bindings (request-bindings
(send/suspend (let ([question "Place your order"]) (send/suspend (let ([question "Place your order"])
(build-suspender (lambda (k-url)
`(,question) `(html (head (title ,question))
`(,question (input ([type "text"] [name "order"]))))))))]) (body (form ([action ,k-url] [method "post"])
,question
(input ([type "text"] [name "order"]))))))))))])
(if (string=? "coconut" order) (if (string=? "coconut" order)
(continue-shopping) (continue-shopping)
(retry-order)))) (retry-order))))
@ -24,11 +26,12 @@
(define (continue-shopping) (define (continue-shopping)
(let* ([next-request (let* ([next-request
(send/forward (send/forward
(build-suspender (lambda (k-url)
'("Keep shopping") `(html (head (title "Keep shopping"))
`((p "Your order has shipped to a random location. You may not go back.") (body (form ([action ,k-url] [method "post"])
(p (input ([type "submit"] [name "go"] [value "Keep Shopping"]))) (p "Your order has shipped to a random location. You may not go back.")
(p (input ([type "submit"] [name "stop"] [value "Logout"]))))))] (p (input ([type "submit"] [name "go"] [value "Keep Shopping"])))
(p (input ([type "submit"] [name "stop"] [value "Logout"]))))))))]
[next (request-bindings next-request)]) [next (request-bindings next-request)])
(cond (cond
[(exists-binding? 'go next) [(exists-binding? 'go next)
@ -50,5 +53,3 @@
(define goodbye-page (define goodbye-page
`(html (head (title "Goodbye")) `(html (head (title "Goodbye"))
(body (p "Thank you for shopping."))))) (body (p "Thank you for shopping.")))))

11
collects/web-server/default-web-root/servlets/tests/error.ss Normal file
View File

@ -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?")))))

3
collects/web-server/default-web-root/servlets/tests/incremental.ss
View File

@ -5,7 +5,8 @@
(define timeout +inf.0) (define timeout +inf.0)
(define (start initial-request) (define (start initial-request)
(send/finish (send/finish
(make-html-response/incremental (make-response/incremental
200 "Okay" (current-seconds) #"text/html" '()
(lambda (output-chunk) (lambda (output-chunk)
(output-chunk "<html><head><title>" (output-chunk "<html><head><title>"
"my-title</title></head>\n") "my-title</title></head>\n")

18
collects/web-server/default-web-root/servlets/tests/module-suspended-init.ss
View File

@ -12,14 +12,18 @@
'name 'name
(request-bindings (request-bindings
(send/suspend (let ([question "What is your name?"]) (send/suspend (let ([question "What is your name?"])
(build-suspender (lambda (k-url)
`(,question) `(html (head (title ,question))
`(,question (input ([type "text"] [name "name"]))))))))]) (body (form ([action ,k-url] [method "post"])
,question
(input ([type "text"] [name "order"]))))))))))])
`(html (head (title "Hi " ,name "!")) `(html (head (title "Hi " ,name "!"))
(body (p "Hello, " ,name "! Don't you feel special now?"))))) (body (p "Hello, " ,name "! Don't you feel special now?")))))
(send/suspend (send/suspend
(build-suspender '("Module Init") (lambda (k-url)
'((p "Maybe calling send/suspend during the module initialization is not a good idea.") `(html (head (title "Module Init"))
(p "This call to send/suspend fails in the development environment since the parameter is #f") (body (form ([action ,k-url] [method "post"])
(p "It fails in the server because the instance id is not yet installed into the table."))))) (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.")))))))

14
collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix.ss
View File

@ -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))))))

14
collects/web-server/default-web-root/servlets/tests/new-suite/jas01.ss
View File

@ -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))))))

19
collects/web-server/default-web-root/servlets/tests/new-suite/pr5565.ss
View File

@ -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)))))

10
collects/web-server/default-web-root/servlets/tests/new-suite/pr7935-other.ss
View File

@ -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)))

8
collects/web-server/default-web-root/servlets/tests/suspended-module.ss
View File

@ -12,8 +12,10 @@
'name 'name
(request-bindings (request-bindings
(send/suspend (let ([question "What is your name?"]) (send/suspend (let ([question "What is your name?"])
(build-suspender (lambda (k-url)
`(,question) `(html (head (title ,question))
`(,question (input ([type "text"] [name "name"]))))))))]) (body (form ([action ,k-url] [method "post"])
,question
(input ([type "text"] [name "order"]))))))))))])
`(html (head (title "Hi " ,name "!")) `(html (head (title "Hi " ,name "!"))
(body (p "Hello, " ,name "! Don't you feel special now?")))))) (body (p "Hello, " ,name "! Don't you feel special now?"))))))

21
collects/web-server/dispatchers/dispatch-host.ss
View File

@ -1,7 +1,9 @@
(module dispatch-host mzscheme (module dispatch-host mzscheme
(require (lib "contract.ss")) (require (lib "contract.ss")
(require "dispatch.ss" (lib "plt-match.ss")
"../private/servlet-helpers.ss") (lib "url.ss" "net")
"../request-structs.ss"
"dispatch.ss")
(provide/contract (provide/contract
[interface-version dispatcher-interface-version?] [interface-version dispatcher-interface-version?]
[make ((symbol? . -> . dispatcher?) . -> . dispatcher?)]) [make ((symbol? . -> . dispatcher?) . -> . dispatcher?)])
@ -9,4 +11,15 @@
(define interface-version 'v1) (define interface-version 'v1)
(define ((make lookup-dispatcher) conn req) (define ((make lookup-dispatcher) conn req)
(define host (get-host (request-uri req) (request-headers/raw req))) (define host (get-host (request-uri req) (request-headers/raw req)))
((lookup-dispatcher host) conn req))) ((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 '<none>])))

13
collects/web-server/private/configure.ss
View File

@ -30,6 +30,19 @@
; - change all configuration paths (in the configure servlet and in the server) to ; - change all configuration paths (in the configure servlet and in the server) to
; use a platform independent representation (i.e. a listof strings) ; 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 default-configuration-path default-configuration-table-path)
(define (set-config-path! new) (define (set-config-path! new)
(set! default-configuration-path new)) (set! default-configuration-path new))

72
collects/web-server/private/servlet-helpers.ss
View File

@ -2,16 +2,14 @@
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "xml.ss" "xml")
(lib "base64.ss" "net") (lib "base64.ss" "net")
(lib "url.ss" "net")
(lib "uri-codec.ss" "net")) (lib "uri-codec.ss" "net"))
(require "util.ss" (require "util.ss"
"bindings.ss" "bindings.ss"
"../servlet-structs.ss"
"../request-structs.ss" "../request-structs.ss"
"../response-structs.ss") "../response-structs.ss")
(provide (all-from "bindings.ss") (provide (all-from "bindings.ss")
(all-from "../response-structs.ss")
(all-from "../request-structs.ss")) (all-from "../request-structs.ss"))
(define (request-headers request) (define (request-headers request)
@ -30,31 +28,6 @@
value)]) value)])
(request-bindings/raw request))) (request-bindings/raw request)))
;; get-host : Url (listof (cons Symbol String)) -> Symbol
;; host names are case insesitive---Internet RFC 1034
(define DEFAULT-HOST-NAME '<none>)
(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) ; redirection-status = (make-redirection-status nat str)
(define-struct redirection-status (code message)) (define-struct redirection-status (code message))
@ -68,34 +41,21 @@
(make-response/full (redirection-status-code perm/temp) (make-response/full (redirection-status-code perm/temp)
(redirection-status-message perm/temp) (redirection-status-message perm/temp)
(current-seconds) #"text/html" (current-seconds) #"text/html"
`((Location . ,uri)) (list (redirect-page uri))))) `((Location . ,uri)) (list))))
; : str -> str ; with-errors-to-browser
(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
; to report exceptions that occur later to the browser ; to report exceptions that occur later to the browser
; this must be called at the begining of a servlet ; this must be called at the begining of a servlet
(define (report-errors-to-browser send/finish-or-back) (define (with-errors-to-browser send/finish-or-back thunk)
(uncaught-exception-handler (with-handlers ([exn? (lambda (exn)
(lambda (exn) (send/finish-or-back
(send/finish-or-back `(html (head (title "Servlet Error"))
`(html (head (title "Servlet Error")) (body ([bgcolor "white"])
(body ([bgcolor "white"]) (p "The following error occured: "
(p "The following error occured: " (pre ,(exn->string exn)))))))])
(pre ,(exn->string exn))))))))) (thunk)))
; Authentication ; Authentication
(define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)")) (define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)"))
(define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x)) (define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x))
;:(define match-authentication (type: (str -> (or/c false (list str str str))))) ;:(define match-authentication (type: (str -> (or/c false (list str str str)))))
@ -125,20 +85,12 @@
(let ([rx (byte-regexp #"^Basic .*")]) (let ([rx (byte-regexp #"^Basic .*")])
(lambda (a) (regexp-match rx a)))) (lambda (a) (regexp-match rx a))))
(provide ; all-from (provide ; all-from
with-errors-to-browser
(rename uri-decode translate-escapes)) (rename uri-decode translate-escapes))
(provide/contract (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?)))] [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?)] [redirect-to ((string?) (redirection-status?) . opt-> . response/full?)]
[permanently redirection-status?] [permanently redirection-status?]
[temporarily redirection-status?] [temporarily redirection-status?]

80
collects/web-server/prototype-web-server/lang-api/web-extras.ss
View File

@ -1,14 +1,23 @@
(module web-extras mzscheme (module web-extras mzscheme
(require (lib "contract.ss") (require (lib "url.ss" "net")
(lib "etc.ss") "../private/web.ss"
(lib "plt-match.ss") (only "../../private/servlet-helpers.ss"
(lib "base64.ss" "net") extract-user-pass
(lib "url.ss" "net") redirect-to
"../../request-structs.ss" permanently
"../../response-structs.ss" temporarily
"../private/web.ss") see-other
request-bindings
request-headers))
(provide send/suspend/dispatch (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 (define-syntax send/suspend/dispatch
(syntax-rules () (syntax-rules ()
@ -21,55 +30,4 @@
(embed-proc/url k-url proc))))))])) (embed-proc/url k-url proc))))))]))
(define (redirect/get) (define (redirect/get)
(send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily)))) (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?]))