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

6
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
send/finish
(lambda ()
`(html (head (title "Acknowledgements")) `(html (head (title "Acknowledgements"))
(body (a ([name "acknowledgements"] [value "acknowledgements"])) (body (a ([name "acknowledgements"] [value "acknowledgements"]))
(h1 "Acknowledgements") (h1 "Acknowledgements")
(p) (p)
,(get-general-acks) ,(get-general-acks)
(p) (p)
,(get-translating-acks))))) ,(get-translating-acks)))))))

6
collects/help/servlets/doc-anchor.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 ()
(let* ([bindings (request-bindings initial-request)] (let* ([bindings (request-bindings initial-request)]
[offset (with-handlers ((void (lambda _ #f))) [offset (with-handlers ((void (lambda _ #f)))
(string->number (string->number
@ -13,4 +15,4 @@
(read-doc (extract-binding/single 'file bindings) (read-doc (extract-binding/single 'file bindings)
(extract-binding/single 'caption bindings) (extract-binding/single 'caption bindings)
(extract-binding/single 'name bindings) (extract-binding/single 'name bindings)
offset)))) offset))))))

6
collects/help/servlets/doc-content.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 ()
(let* ([bindings (request-bindings initial-request)] (let* ([bindings (request-bindings initial-request)]
[file (extract-binding/single 'file bindings)] [file (extract-binding/single 'file bindings)]
[caption (extract-binding/single 'caption bindings)] [caption (extract-binding/single 'caption bindings)]
@ -16,4 +18,4 @@
`(html (head (title "PLT Help Desk") `(html (head (title "PLT Help Desk")
,hd-css ,hd-css
,@hd-links) ,@hd-links)
,(read-lines file caption offset))))) ,(read-lines file caption offset)))))))

6
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
send/finish
(lambda ()
(let ([bindings (request-bindings initial-request)]) (let ([bindings (request-bindings initial-request)])
`(html (head ,hd-css ,@hd-links (title "PLT collection message")) `(html (head ,hd-css ,@hd-links (title "PLT collection message"))
(body ,(format-collection-message (body ,(format-collection-message
(extract-binding/single 'msg bindings)) (extract-binding/single 'msg bindings))
(hr)))))) (hr))))))))

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

@ -43,7 +43,9 @@
(br) (br)))) (br) (br))))
(define (start initial-request) (define (start initial-request)
(report-errors-to-browser send/finish) (with-errors-to-browser
send/finish
(lambda ()
`(html `(html
(head (title "PLT Help Desk")) (head (title "PLT Help Desk"))
(body (body
@ -58,4 +60,4 @@
"((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"]) "((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"])
(font ([color "forestgreen"]) "Send a bug report"))) (font ([color "forestgreen"]) "Send a bug report")))
(p) (p)
(i "Version: " ,(plt-version))))))))) (i "Version: " ,(plt-version)))))))))))

6
collects/help/servlets/howtodrscheme.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 "DrScheme")) (head ,hd-css ,@hd-links (title "DrScheme"))
(body (body
@ -24,4 +26,4 @@
"Languages")) "Languages"))
": Languages supported by DrScheme") ": Languages supported by DrScheme")
(li (b ,(main-manual-page "drscheme")) (li (b ,(main-manual-page "drscheme"))
": The complete user manual")))))) ": The complete user manual"))))))))

6
collects/help/servlets/howtoprogram.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 "Program Design")) (head ,hd-css ,@hd-links (title "Program Design"))
(body (body
@ -30,4 +32,4 @@
": For programmers with lots of experience in other languages")) ": For programmers with lots of experience in other languages"))
,(color-highlight `(h2 "For Teachers and Researchers")) ,(color-highlight `(h2 "For Teachers and Researchers"))
(ul (li (b (a ([href "/servlets/research/why.ss"]) "Why DrScheme?")) (ul (li (b (a ([href "/servlets/research/why.ss"]) "Why DrScheme?"))
": PLT's vision ")))))) ": 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"))))))))

6
collects/help/servlets/howtouse.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 "Help Desk")) (head ,hd-css ,@hd-links (title "Help Desk"))
(body (body
@ -68,4 +70,4 @@
(b "Choose Language...") (b "Choose Language...")
" menu item from the " " menu item from the "
(b "Language") (b "Language")
" menu to change the language.")))) " menu to change the language."))))))

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

@ -7,7 +7,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 ()
(let* ([bindings (request-bindings initial-request)] (let* ([bindings (request-bindings initial-request)]
[manual (extract-binding/single 'manual bindings)] [manual (extract-binding/single 'manual bindings)]
[raw-section (extract-binding/single 'section bindings)] [raw-section (extract-binding/single 'section bindings)]
@ -28,4 +30,4 @@
"Requested section: " "Requested section: "
,section))))]) ,section))))])
(finddoc-page-anchor manual section))]) (finddoc-page-anchor manual section))])
(send/finish (redirect-to page))))) (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))))))

6
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
send/finish
(lambda ()
(let ([bindings (request-bindings initial-request)]) (let ([bindings (request-bindings initial-request)])
(no-manual (extract-binding/single 'manual bindings) (no-manual (extract-binding/single 'manual bindings)
(extract-binding/single 'name bindings) (extract-binding/single 'name bindings)
(extract-binding/single 'link 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)]

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") "."))))))

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

@ -29,7 +29,9 @@ 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
send/finish
(lambda ()
(let () (let ()
;; doc subcollection name -> boolean ;; doc subcollection name -> boolean
(define (search-type->search-level st) (define (search-type->search-level st)
@ -291,5 +293,4 @@ is stored in a module top-level and that's namespace-specific.
(cond [(not doc.txt) #t] (cond [(not doc.txt) #t]
[(equal? doc.txt "false") #f] [(equal? doc.txt "false") #f]
[else #t]) [else #t])
lang-name)))]))))) 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")
".")))) "."))))))

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

@ -23,7 +23,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 (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme")) `(html (head ,hd-css ,@hd-links (TITLE "How to do things in Scheme"))
(body (body
(h1 "How to do things in Scheme") (h1 "How to do things in Scheme")
@ -33,4 +35,4 @@
(a ((href "/servlets/howtouse.ss#search")) "searching") (a ((href "/servlets/howtouse.ss#search")) "searching")
" in Help Desk. Also, check " " in Help Desk. Also, check "
(a ((href "http://www.htus.org/")) (i "How to Use Scheme")) (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."))))))

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

@ -7,9 +7,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
@ -150,4 +150,4 @@
" (append" (BR) " (append" (BR)
" '(\"<PRE>\")" (BR) " '(\"<PRE>\")" (BR)
" (map string->html strings)" (BR) " (map string->html strings)" (BR)
" '(\"</PRE>\"))))))))"))))) " '(\"</PRE>\"))))))))")))))))

7
collects/help/servlets/scheme/misc/database.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
@ -31,4 +32,4 @@
" " " "
(A ((HREF "http://schematics.sourceforge.net/schemeql.html") (A ((HREF "http://schematics.sourceforge.net/schemeql.html")
(TARGET "_top")) "http://schematics.sourceforge.net/schemeql.html")) (TARGET "_top")) "http://schematics.sourceforge.net/schemeql.html"))
" for more details.")))) " for more details."))))))

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

@ -9,9 +9,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
@ -32,4 +32,4 @@
"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\"))")))))))

8
collects/help/servlets/scheme/misc/script.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
@ -46,4 +46,4 @@
(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") "."))))))

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

@ -9,9 +9,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
@ -31,4 +31,4 @@
"to stand-alone executables creation. " "to stand-alone executables creation. "
"See " "See "
,(main-manual-page "mzc") ,(main-manual-page "mzc")
" for more information.")))) " for more information."))))))

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

@ -9,9 +9,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
@ -23,4 +23,4 @@
"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."))))))

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

@ -9,7 +9,9 @@
(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
send/finish
(lambda ()
`(html `(html
(head ,hd-css ,@hd-links (title "Scheme Languages")) (head ,hd-css ,@hd-links (title "Scheme Languages"))
(body (body
@ -100,4 +102,4 @@
(a ([name "lang-sel"] [value "language, setting"])) (a ([name "lang-sel"] [value "language, setting"]))
"To change the" "To change the"
" language, select the " (b "Choose Language...") " item in the " " language, select the " (b "Choose Language...") " item in the "
(B "Language") " menu.")))) (B "Language") " menu."))))))

6
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
send/finish
(lambda ()
`(html `(html
(head (title "Teachpacks")) (head (title "Teachpacks"))
(body (h1 "Teachpacks") (body (h1 "Teachpacks")
(ul (li (b (a ([href ,(get-manual-index "teachpack")]) (ul (li (b (a ([href ,(get-manual-index "teachpack")])
"Teachpacks for \"How to Design Programs\""))) "Teachpacks for \"How to Design Programs\"")))
(li (b (a ([href ,(get-manual-index "teachpack-htdc")]) (li (b (a ([href ,(get-manual-index "teachpack-htdc")])
"Teachpacks for \"How to Design Classes\"")))))))) "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)

10
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
(lambda (k-url)
(let ([prompt (string-append "Enter " which-number ": ")]) (let ([prompt (string-append "Enter " which-number ": ")])
(build-suspender `(html (head (title ,prompt))
(list prompt) (body (form ([action ,k-url]
`(,@error-message [method "post"])
,@error-message
(p ,prompt (input ([type "text"] [name "n"]))) (p ,prompt (input ([type "text"] [name "n"])))
(input ([type "submit"] [value "Okay"]))))))))] (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."))))))))

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

19
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 "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 "go"] [value "Keep Shopping"])))
(p (input ([type "submit"] [name "stop"] [value "Logout"]))))))] (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")

16
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"))
(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 "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."))))) (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))

64
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?]))