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 timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
(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)))))
,(get-translating-acks)))))))

6
collects/help/servlets/doc-anchor.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 ()
(let* ([bindings (request-bindings initial-request)]
[offset (with-handlers ((void (lambda _ #f)))
(string->number
@ -13,4 +15,4 @@
(read-doc (extract-binding/single 'file bindings)
(extract-binding/single 'caption 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 timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
(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)]
@ -16,4 +18,4 @@
`(html (head (title "PLT Help Desk")
,hd-css
,@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 timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
(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))))))
(hr))))))))

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

@ -43,7 +43,9 @@
(br) (br))))
(define (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
`(html
(head (title "PLT Help Desk"))
(body
@ -58,4 +60,4 @@
"((dynamic-require '(lib |bug-report.ss| |help|) 'help-desk:report-bug))"])
(font ([color "forestgreen"]) "Send a bug report")))
(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 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 "DrScheme"))
(body
@ -24,4 +26,4 @@
"Languages"))
": Languages supported by 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 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 "Program Design"))
(body
@ -30,4 +32,4 @@
": 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 "))))))
": 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"))))))))

6
collects/help/servlets/howtouse.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 "Help Desk"))
(body
@ -68,4 +70,4 @@
(b "Choose Language...")
" menu item from the "
(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 (start initial-request)
(report-errors-to-browser send/finish)
(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)]
@ -28,4 +30,4 @@
"Requested section: "
,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 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))))))

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

@ -8,11 +8,13 @@
(define timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
(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))))
(extract-binding/single 'link bindings))))))
(define (no-manual manual label link)
(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 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") "."))))))

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 (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
(let ()
;; doc subcollection name -> boolean
(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]
[(equal? doc.txt "false") #f]
[else #t])
lang-name)))])))))
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")
"."))))
"."))))))

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

@ -23,7 +23,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 "How to do things in Scheme"))
(body
(h1 "How to do things in Scheme")
@ -33,4 +35,4 @@
(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."))))))

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

@ -7,9 +7,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
@ -150,4 +150,4 @@
" (append" (BR)
" '(\"<PRE>\")" (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 (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
`(HTML
(HEAD ,hd-css
,@hd-links
@ -31,4 +32,4 @@
" "
(A ((HREF "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 (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
`(HTML
(HEAD ,hd-css
,@hd-links
@ -32,4 +32,4 @@
"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\"))")))))
(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 (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
`(HTML
(HEAD ,hd-css
,@hd-links
@ -46,4 +46,4 @@
(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") "."))))
(TT "argv") "."))))))

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

@ -9,9 +9,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
@ -31,4 +31,4 @@
"to stand-alone executables creation. "
"See "
,(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 (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
`(HTML
(HEAD ,hd-css
,@hd-links
@ -23,4 +23,4 @@
"an extension to MzScheme using the C programming language. "
"See "
,(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)
(with-color "forestgreen" `(B ,s)))
(define (start initial-request)
(report-errors-to-browser send/finish)
(with-errors-to-browser
send/finish
(lambda ()
`(html
(head ,hd-css ,@hd-links (title "Scheme Languages"))
(body
@ -100,4 +102,4 @@
(a ([name "lang-sel"] [value "language, setting"]))
"To change 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 timeout +inf.0)
(define (start initial-request)
(report-errors-to-browser send/finish)
(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\""))))))))
"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")
(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)

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

@ -11,11 +11,13 @@
'n
(request-bindings
(send/suspend
(lambda (k-url)
(let ([prompt (string-append "Enter " which-number ": ")])
(build-suspender
(list prompt)
`(,@error-message
`(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"]))))))))]
(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."))))))))

12
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
(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"])))))))
(input ([type "submit"] [name "submit"] [value "Okay"])))))))))
; field-name : nat nat -> str
(define (field-name row column)

19
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.")
(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"]))))))]
(p (input ([type "submit"] [name "stop"] [value "Logout"]))))))))]
[next (request-bindings next-request)])
(cond
[(exists-binding? 'go next)
@ -50,5 +53,3 @@
(define goodbye-page
`(html (head (title "Goodbye"))
(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")

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

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

@ -2,16 +2,14 @@
(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 "../response-structs.ss")
(all-from "../request-structs.ss"))
(define (request-headers request)
@ -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)
(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)))))))))
(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
[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)))))