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 timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
`(html (head (title "Acknowledgements"))
(body (a ([name "acknowledgements"] [value "acknowledgements"]))
(h1 "Acknowledgements")
(p)
,(get-general-acks)
(p)
,(get-translating-acks)))))
(with-errors-to-browser
send/finish
(lambda ()
`(html (head (title "Acknowledgements"))
(body (a ([name "acknowledgements"] [value "acknowledgements"]))
(h1 "Acknowledgements")
(p)
,(get-general-acks)
(p)
,(get-translating-acks)))))))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -5,7 +5,9 @@
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
`(html
(head ,hd-css ,@hd-links (title "Mailing Lists"))
(body
@ -79,4 +81,4 @@
(a ([href "mailto:plt-scheme-es-request@list.cs.brown.edu"])
"plt-scheme-es-request@list.cs.brown.edu"))
" con la palabra `help' en el asunto o en el cuerpo de tu mensaje. "
"Recibirás un mensaje de regreso con instrucciones."))))
"Recibirás un mensaje de regreso con instrucciones."))))))

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

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

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

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

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

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

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

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

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

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

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

@ -8,7 +8,7 @@
[txt (cadr url/txt)])
`(li (b (a ([href ,(string-append "/servlets/scheme/misc/" url)])
,txt)))))
(define links
'(("standalone.ss" "How to build a stand-alone executable")
("graphics.ss" "How to write graphics programs")
@ -18,19 +18,21 @@
("activex.ss" "How to use ActiveX components")
("database.ss" "How to connect to databases")
("system.ss" "How to call low-level system routines")))
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
`(html (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme"))
(body
(h1 "How to do things in Scheme")
(ul ,@(map make-link-line links))
(p)
"If you did't find what you're looking for in the list above, try "
(a ((href "/servlets/howtouse.ss#search")) "searching")
" in Help Desk. Also, check "
(a ((href "http://www.htus.org/")) (i "How to Use Scheme"))
"."))))
(with-errors-to-browser
send/finish
(lambda ()
`(html (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme"))
(body
(h1 "How to do things in Scheme")
(ul ,@(map make-link-line links))
(p)
"If you did't find what you're looking for in the list above, try "
(a ((href "/servlets/howtouse.ss#search")) "searching")
" in Help Desk. Also, check "
(a ((href "http://www.htus.org/")) (i "How to Use Scheme"))
"."))))))

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

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

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

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

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

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

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

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

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

@ -9,26 +9,26 @@
(define timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
`(HTML
(HEAD ,hd-css
,@hd-links
(TITLE "How to build a stand-alone executable"))
(BODY
(H1 "How to build a stand-alone executable")
(A ((NAME "exec") (VALUE "Standalone executables")))
(A ((name "exec2") (VALUE "Stand-alone executables")))
"To create stand-alone executables, use DrScheme's "
(tt "Scheme | Create Executable ...")
" menu item. This menu is sensitive to the language levels; "
"the " (tt "module") " language permits the most flexibility "
"in creating executables."
(p)
"The mzc compiler provides a more low-level interface "
"to stand-alone executables creation. "
"See "
,(main-manual-page "mzc")
" for more information."))))
(with-errors-to-browser
send/finish
(lambda ()
`(HTML
(HEAD ,hd-css
,@hd-links
(TITLE "How to build a stand-alone executable"))
(BODY
(H1 "How to build a stand-alone executable")
(A ((NAME "exec") (VALUE "Standalone executables")))
(A ((name "exec2") (VALUE "Stand-alone executables")))
"To create stand-alone executables, use DrScheme's "
(tt "Scheme | Create Executable ...")
" menu item. This menu is sensitive to the language levels; "
"the " (tt "module") " language permits the most flexibility "
"in creating executables."
(p)
"The mzc compiler provides a more low-level interface "
"to stand-alone executables creation. "
"See "
,(main-manual-page "mzc")
" for more information."))))))

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

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

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

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

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

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

21
collects/htdp/servlet.ss
View File

@ -3,12 +3,23 @@
(require (lib "servlet-env.ss" "web-server" "tools")
(lib "error.ss" "htdp")
(lib "xml.ss" "xml")
(lib "list.ss")
(lib "prim.ss" "lang")
(lib "unitsig.ss"))
(provide (all-from-except (lib "servlet-env.ss" "web-server" "tools") build-suspender)
(lib "etc.ss"))
(provide (all-from (lib "servlet-env.ss" "web-server" "tools"))
(rename wrapped-build-suspender build-suspender))
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
(define build-suspender
(opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
(lambda (k-url)
`(html (head ,head-attributes
(meta ([http-equiv "Pragma"] [content "no-cache"])) ; don't cache in netscape
(meta ([http-equiv "Expires"] [content "-1"])) ; don't cache in IE
; one site said to use -1, another said to use 0.
(title . ,title))
(body ,body-attributes
(form ([action ,k-url] [method "post"])
,@content))))))
(define wrapped-build-suspender
(case-lambda
[(title content)
@ -42,4 +53,4 @@
(define (attribute-pair? b)
(and (pair? b)
(symbol? (car b))
(string? (cdr b)))))
(string? (cdr b)))))

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

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

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

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

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

@ -13,9 +13,11 @@
'order
(request-bindings
(send/suspend (let ([question "Place your order"])
(build-suspender
`(,question)
`(,question (input ([type "text"] [name "order"]))))))))])
(lambda (k-url)
`(html (head (title ,question))
(body (form ([action ,k-url] [method "post"])
,question
(input ([type "text"] [name "order"]))))))))))])
(if (string=? "coconut" order)
(continue-shopping)
(retry-order))))
@ -24,11 +26,12 @@
(define (continue-shopping)
(let* ([next-request
(send/forward
(build-suspender
'("Keep shopping")
`((p "Your order has shipped to a random location. You may not go back.")
(p (input ([type "submit"] [name "go"] [value "Keep Shopping"])))
(p (input ([type "submit"] [name "stop"] [value "Logout"]))))))]
(lambda (k-url)
`(html (head (title "Keep shopping"))
(body (form ([action ,k-url] [method "post"])
(p "Your order has shipped to a random location. You may not go back.")
(p (input ([type "submit"] [name "go"] [value "Keep Shopping"])))
(p (input ([type "submit"] [name "stop"] [value "Logout"]))))))))]
[next (request-bindings next-request)])
(cond
[(exists-binding? 'go next)
@ -49,6 +52,4 @@
(define goodbye-page
`(html (head (title "Goodbye"))
(body (p "Thank you for shopping.")))))
(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 (start initial-request)
(send/finish
(make-html-response/incremental
(make-response/incremental
200 "Okay" (current-seconds) #"text/html" '()
(lambda (output-chunk)
(output-chunk "<html><head><title>"
"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
(request-bindings
(send/suspend (let ([question "What is your name?"])
(build-suspender
`(,question)
`(,question (input ([type "text"] [name "name"]))))))))])
(lambda (k-url)
`(html (head (title ,question))
(body (form ([action ,k-url] [method "post"])
,question
(input ([type "text"] [name "order"]))))))))))])
`(html (head (title "Hi " ,name "!"))
(body (p "Hello, " ,name "! Don't you feel special now?")))))
(send/suspend
(build-suspender '("Module Init")
'((p "Maybe calling send/suspend during the module initialization is not a good idea.")
(p "This call to send/suspend fails in the development environment since the parameter is #f")
(p "It fails in the server because the instance id is not yet installed into the table.")))))
(lambda (k-url)
`(html (head (title "Module Init"))
(body (form ([action ,k-url] [method "post"])
(p "Maybe calling send/suspend during the module initialization is not a good idea.")
(p "This call to send/suspend fails in the development environment since the parameter is #f")
(p "It fails in the server because the instance id is not yet installed into the table.")))))))

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

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

@ -1,7 +1,9 @@
(module dispatch-host mzscheme
(require (lib "contract.ss"))
(require "dispatch.ss"
"../private/servlet-helpers.ss")
(require (lib "contract.ss")
(lib "plt-match.ss")
(lib "url.ss" "net")
"../request-structs.ss"
"dispatch.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make ((symbol? . -> . dispatcher?) . -> . dispatcher?)])
@ -9,4 +11,15 @@
(define interface-version 'v1)
(define ((make lookup-dispatcher) conn req)
(define host (get-host (request-uri req) (request-headers/raw req)))
((lookup-dispatcher host) conn req)))
((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
; use a platform independent representation (i.e. a listof strings)
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
(define build-suspender
(opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
(lambda (k-url)
`(html (head ,head-attributes
(meta ([http-equiv "Pragma"] [content "no-cache"])) ; don't cache in netscape
(meta ([http-equiv "Expires"] [content "-1"])) ; don't cache in IE
; one site said to use -1, another said to use 0.
(title . ,title))
(body ,body-attributes
(form ([action ,k-url] [method "post"])
,@content))))))
(define default-configuration-path default-configuration-table-path)
(define (set-config-path! new)
(set! default-configuration-path new))

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

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

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

@ -1,14 +1,23 @@
(module web-extras mzscheme
(require (lib "contract.ss")
(lib "etc.ss")
(lib "plt-match.ss")
(lib "base64.ss" "net")
(lib "url.ss" "net")
"../../request-structs.ss"
"../../response-structs.ss"
"../private/web.ss")
(require (lib "url.ss" "net")
"../private/web.ss"
(only "../../private/servlet-helpers.ss"
extract-user-pass
redirect-to
permanently
temporarily
see-other
request-bindings
request-headers))
(provide send/suspend/dispatch
redirect/get)
redirect/get
extract-user-pass
redirect-to
permanently
temporarily
see-other
request-bindings
request-headers)
(define-syntax send/suspend/dispatch
(syntax-rules ()
@ -21,55 +30,4 @@
(embed-proc/url k-url proc))))))]))
(define (redirect/get)
(send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily))))
; redirection-status = (make-redirection-status nat str)
(define-struct redirection-status (code message))
(define permanently (make-redirection-status 301 "Moved Permanently"))
(define temporarily (make-redirection-status 302 "Moved Temporarily"))
(define see-other (make-redirection-status 303 "See Other"))
; : str [redirection-status] -> response
(define redirect-to
(opt-lambda (uri [perm/temp permanently])
(make-response/full (redirection-status-code perm/temp)
(redirection-status-message perm/temp)
(current-seconds) #"text/html"
`((Location . ,uri)) (list))))
; make-html-response/incremental : ((string -> void) -> void) -> response/incremental
(define (make-html-response/incremental chunk-maker)
(make-response/incremental
200 "Okay" (current-seconds) #"text/html" '()
chunk-maker))
; Authentication
; basic-auth-extract-user-pass : (listof (cons sym bytes)) -> (or/c #f (cons str str))
;; Notes (GregP)
;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1)
;; e.g. an authorization header will look like this:
;; Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==
;; 2. Headers should be read as bytes and then translated to unicode as appropriate.
;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes
(define (basic-auth-extract-user-pass headers)
(match (headers-assq* #"Authorization" headers)
[#f #f]
[(struct header (_ basic-credentials))
(cond
[(and (regexp-match #rx#"^Basic .*"
basic-credentials)
(regexp-match #rx"([^:]*):(.*)"
(base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))))
=> (lambda (user-pass)
(cons (cadr user-pass) (caddr user-pass)))]
[else #f])]))
(provide/contract
; XXX contract maybe
[basic-auth-extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))]
[make-html-response/incremental (((string? . -> . void) . -> . void) . -> . response/incremental?)]
[redirect-to ((string?) (redirection-status?) . opt-> . response/full?)]
[permanently redirection-status?]
[temporarily redirection-status?]
[see-other redirection-status?]))
(send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily)))))