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

Removing unit servlets

Browse Source 
svn: r6101
This commit is contained in:
Jay McCarthy 2007-04-30 17:51:11 +00:00
parent ea004857cf
commit 00f2c671a3
60 changed files with 1916 additions and 1301 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/add.ss
View File

@ -1,9 +1,8 @@
(require (lib "unit.ss") (module add mzscheme
(lib "servlet-sig.ss" "web-server") (require (lib "servlet.ss" "web-server"))
(lib "date.ss")) (provide (all-defined))
(define interface-version 'v1)
(unit (import servlet^) (define timeout +inf.0)
(export)
; request-number : str -> num ; request-number : str -> num
(define (request-number which-number) (define (request-number which-number)
@ -22,9 +21,10 @@
(input ([type "text"] [name "number"] [value ""])) (input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"] [name "enter"] [value "Enter"]))))))) (input ([type "submit"] [name "enter"] [value "Enter"])))))))
(send/suspend (define (start initial-request)
(lambda (k-url) (send/suspend
`(html (head (title "Sum")) (lambda (k-url)
(body ([bgcolor "white"]) `(html (head (title "Sum"))
(p "The sum is " (body ([bgcolor "white"])
,(number->string (+ (request-number "first") (request-number "second"))))))))) (p "The sum is "
,(number->string (+ (request-number "first") (request-number "second"))))))))))

26
collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/count.ss
View File

@ -1,15 +1,15 @@
(require (lib "unit.ss") (module count mzscheme
(lib "servlet-sig.ss" "web-server") (require (lib "date.ss"))
(lib "date.ss")) (provide (all-defined))
(define interface-version 'v1)
(define timeout +inf.0)
(let ([count 0] (define count 0)
[date (date->string (seconds->date (current-seconds)) 'time-too)]) (define a-date (date->string (seconds->date (current-seconds)) 'time-too))
(unit (import servlet^) (define (start initial-request)
(export) (set! count (add1 count))
(set! count (add1 count)) `(html (head (title "Counter"))
(body ([bgcolor "white"])
`(html (head (title "Counter")) (p "This servlet was called " ,(number->string count)
(body ([bgcolor "white"]) " times since loaded on " ,a-date ".")))))
(p "This servlet was called " ,(number->string count)
" times since loaded on " ,date ".")))))

16
collects/web-server/default-web-root/htdocs/Defaults/documentation/examples/hello.ss
View File

@ -1,11 +1,11 @@
(require (lib "unit.ss") (module hello mzscheme
(lib "servlet-sig.ss" "web-server")) (provide (all-defined))
(define interface-version 'v1)
(unit (import servlet^) (define timeout +inf.0)
(export)
(define the-text "Hello, Web!") (define the-text "Hello, Web!")
`(html (head (title ,the-text)) (define (start initial-request)
(body ([bgcolor "white"]) `(html (head (title ,the-text))
(p ,the-text)))) (body ([bgcolor "white"])
(p ,the-text)))))

31
collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet-examples.html
View File

@ -1 +1,30 @@
<html><head><title>PLT Servlet Examples</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Servlet Examples</h2><p>The table below links to small example servlets.<br />The configuration tool is a larger example.<br />The `go' links only work when served from the PLT Web server.</p><table><tr><th>Source Code</th><th>Evaluate</th></tr><tr><td><a href="examples/add.ss">add.ss</a></td><td><a href="/servlets/examples/add.ss">go</a></td></tr><tr><td><a href="examples/count.ss">count.ss</a></td><td><a href="/servlets/examples/count.ss">go</a></td></tr><tr><td><a href="examples/hello.ss">hello.ss</a></td><td><a href="/servlets/examples/hello.ss">go</a></td></tr></table><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html> <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
<title>PLT Servlet Examples</title>
</head>
<body bgcolor="white">
<img src="/Defaults/documentation/web-server.gif" width="61" height="57"><h2>PLT Servlet Examples</h2>
<p>The table below links to small example servlets.<br>The configuration tool is a larger example.<br>The `go' links only work when served from the PLT Web server.</p>
<table>
<tr>
<th>Source Code</th>
<th>Evaluate</th>
</tr>
<tr>
<td><a href="examples/add.ss">add.ss</a></td>
<td><a href="/servlets/examples/add.ss">go</a></td>
</tr>
<tr>
<td><a href="examples/count.ss">count.ss</a></td>
<td><a href="/servlets/examples/count.ss">go</a></td>
</tr>
<tr>
<td><a href="examples/hello.ss">hello.ss</a></td>
<td><a href="/servlets/examples/hello.ss">go</a></td>
</tr>
</table>
<p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif"></a></p>
</body>
</html>

91
collects/web-server/default-web-root/htdocs/Defaults/documentation/servlet.html
View File

@ -1,34 +1,63 @@
<html><head><title>PLT Web Server: Servlet Interface</title></head><body bgcolor="white"><img src="/Defaults/documentation/web-server.gif" width="61" height="57" /><h2>PLT Web Server: Servlet Interface</h2><p>Instead of serving files from a special directory verbatim, the Web server executes the contained Scheme code and serves the output. By default, the special directory is named "servlets" within the "default-web-root" of the "web-server" collection directory. Each file in that directory must evaluate to a servlet. <!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
A servlet is a <code>unit/sig</code> that imports the <code>servlet^</code> <html>
signature and exports nothing. (Search in <code>help-desk</code> for more information on <code>unit/sig</code> and on signatures.) To construct a <code>unit/sig</code> with the appropriate imports, the servlet must require the two modules providing<code>unit/sig</code>s and the <code>servlet^</code> signature:</p><blockquote><code><pre> <head>
(require (lib "unitsig.ss") <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
(lib "servlet-sig.ss" "web-server")) <title>PLT Web Server: Servlet Interface</title>
(unit/sig () </head>
(import servlet^) <body bgcolor="white">
</pre>&nbsp;&nbsp;...insert servlet code here...<code>)</code></code></blockquote><p>The last value in the <code>unit/sig</code> must be a <em>response</em> to an HTTP request.</p><p>A <code>Response</code> is one of the following: <img src="/Defaults/documentation/web-server.gif" width="61" height="57" />
</p><ul><li>an <code>X-expression</code> representing HTML <br /> <h2>PLT Web Server: Servlet Interface</h2>
(Search for XML in <code>help-desk</code>.)</li><li>a <code>(listof string)</code> where <p>Instead of serving files from a special directory
<ul><li>The first string is the mime type (often "text/html", but see <a href="http://www.cis.ohio-state.edu/cgi-bin/rfc/rfc2822.html">RFC 2822</a> for other options).The rest of the strings provide the document's content.</li></ul></li><li><code>(make-response/full</code> code message seconds mime extras body<code>)</code> where verbatim, the Web server executes the contained
<ul><li>code is a natural number indicating the HTTP response code</li><li>message is a string describing the code to a human</li><li>seconds is a natural number indicating the time the resource was Scheme code and serves the output. By default,
created. Use (current-seconds) for dynamically created responses.</li><li>mime is a string indicating the response type.</li><li>extras is a <code>(listof (cons symbol string))</code> containing extra headers for redirects, authentication, or cookies.</li><li>body is a <code>(listof string)</code></li></ul></li></ul><p>Evaluating <code>(require (lib "servlet-sig.ss" "web-server"))</code> loads the special directory is named "servlets" within
the <code>servlet^</code> signature consisting of the following imports:</p><ul><li>initial-request : <code>request</code>, where a request is <br /><code>(make-request method uri headers bindings host-ip client-ip)</code>, where the "default-web-root" of the "web-server"
<ul><li> method : <code>(Union 'get 'post)</code></li><li> uri : <code>URL</code> <br /> collection directory. Each file in that directory
see the <code>net</code> collection in <code>help-desk</code> for details</li><li> headers : <code>(listof (cons symbol string))</code> <br /> must evaluate to a servlet.</p>
optional HTTP headers for this request</li><li> bindings : <code>(listof (cons symbol string))</code> <br />
name value pairs from the form submitted or the query part of the URL.</li></ul></li></ul><p>The <code>path</code> part of the URL suplies the file path to the servlet relative to the "servlets" directory. However, paths may also contain extra path components that servlets may use as additional input. For example all of the following URLs refer to the same servlet: <ul><li><code>http://www.plt-scheme.org/servlets/my-servlet</code></li><li><code>http://www.plt-scheme.org/servlets/my-servlet/extra</code></li><li><code>http://www.plt-scheme.org/servlets/my-servlet/extra/directories</code></li></ul></p><p>The above imports support handling a single input from a Web form. To ease the development of more interactive servlets, the <code>servlet^</code> signature also provides the following functions:
</p><ul><li><code>send/suspend : (str -&gt; Response) -&gt; request</code></li></ul>The argument, a function that consumes a string, is given a <code>URL</code> that can be used in the document. The argument function must produce a
response corresponding to the document's body. Requests to the
given <code>URL</code> resume the computation at the point
<code>send/suspend</code> was invoked. Thus, the argument function normally
produces an HTML form with the "action" attribute set to the provided
<code>URL</code>. The result of <code>send/suspend</code> represents the
next request.
<ul><li><code>send/finish : Response -&gt;</code> doesn't return <br />This provides a convenient way to report an error or otherwise produce a final response. Once called, all URLs generated by send/suspend become invalid. Calling send/finish allows the system to reclaim resources consumed by the servlet.</li><li><code>adjust-timeout! : Nat -&gt; Void</code><br /> <p>A servlet is a <code>module</code> that provides
The server will shutdown each instance of a servlet after an unspecified default amount of time since the last time that servlet instance handled a request. Calling adjust-timeout! allows programmers to choose this number of seconds. Larger numbers consume more resources three values: an
while smaller numbers force servlet users to restart computations more often. <code>interface-version</code>,
</li></ul><p>The <code>servlet-helpers</code> module, required with <blockquote><code>(require (lib "servlet-helpers.ss" "web-server"))</code></blockquote> provides a few additional functions helpful for constructing servlets: <ul><li><code>extract-binding/single : sym (listof (cons sym str)) -&gt; str</code>This extracts a single value associated with sym in the form bindings. If multiple or zero values are associated with the name, it raises an exception.</li><li>extract-bindings : sym (listof (cons sym str)) -&gt; (listof str)returns a list of values assocaited with the name sym.</li><li><code>extract-user-pass : (listof (cons sym str)) -&gt; (U #f (cons str str))</code><br /><code>(define (extract-user-pass headers) ...)</code>Servlets may easily implement password based authentication by extracting password information from the HTTP headers. The return value is either a pair consisting of the username and password from the headers or #f if no password was provided.</li></ul></p><h3>Special URLs</h3><p>The Web server caches passwords and servlets for performance reasons. Requesting the URL<blockquote><a href="/conf/refresh-passwords"><code>http://my-host/conf/refresh-passwords</code></a></blockquote>reloads the password file. After updating a servlet, loading the URL <blockquote><a href="/conf/refresh-servlets"><code>http://my-host/conf/refresh-servlets</code></a></blockquote>causes the server to reload each servlet on the next invocation. This loses any per-servlet state (not per servlet instance state) computed before the unit invocation.</p> a <code>timeout</code>, and a
<code>start</code> procedure:</p>
<blockquote><code><pre>
(module servlet mzscheme
(require (lib "servlet.ss" "web-server"))
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
...))
</pre></code></blockquote>
<p>The Web server's garbage collect may be invoked at the URL: <blockquote><a href="/conf/collect-garbage"><code>http://my-host/conf/collect-garbage</code></a></blockquote></p> <p>The <code>start</code> procedure should produce a
a <em>response</em> to an HTTP request. Please
refer to the documentation available via the Help
Desk for more information about working with these
values and programming servlets.</p>
<p><a href="servlet-examples.html">Examples of Servlets</a></p><p>Powered by <a href="http://www.plt-scheme.org/"><img width="53" height="19" src="/Defaults/documentation/plt-logo.gif" /></a></p></body></html> <h3>Special URLs</h3>
<p>The Web server caches passwords and servlets for
performance reasons. Requesting the URL</p>
<blockquote><a
href="/conf/refresh-passwords"><code>http://my-host/conf/refresh-passwords</code></a></blockquote>
<p>reloads the password file. After updating a
servlet, loading the
URL</p>
<blockquote><a
href="/conf/refresh-servlets"><code>http://my-host/conf/refresh-servlets</code></a></blockquote>
<p>causes the server to reload each servlet on the
next invocation. This loses any per-servlet state (not
per servlet instance state) computed before the unit
invocation.</p>
<p>The Web server's garbage collect may be invoked at
the URL: </p>
<blockquote><a href="/conf/collect-garbage"><code>http://my-host/conf/collect-garbage</code></a></blockquote>
<p><a href="servlet-examples.html">Examples of Servlets</a></p>
<p>Powered by <a href="http://www.plt-scheme.org/">
<img width="53" height="19"
src="/Defaults/documentation/plt-logo.gif" /></a></p>
</body>
</html>

7
collects/web-server/default-web-root/servlets/configure.ss
View File

@ -2,7 +2,6 @@
; unless you never want to reconfigure the Web server again. ; unless you never want to reconfigure the Web server again.
; The servlet accepts requests only from the *same machine* as the Web server ; The servlet accepts requests only from the *same machine* as the Web server
; for security purposes. ; for security purposes.
(module configure mzscheme
(require (lib "configure.ss" "web-server" "private")) (require (lib "configure.ss" "web-server" "private"))
(provide (all-from (lib "configure.ss" "web-server" "private"))))
servlet

20
collects/web-server/default-web-root/servlets/examples/add.ss
View File

@ -1,9 +1,8 @@
(require (lib "unit.ss") (module add mzscheme
(lib "servlet-sig.ss" "web-server") (require (lib "servlet.ss" "web-server"))
(lib "date.ss")) (provide (all-defined))
(define interface-version 'v1)
(unit (import servlet^) (define timeout +inf.0)
(export)
; request-number : str -> num ; request-number : str -> num
(define (request-number which-number) (define (request-number which-number)
@ -22,7 +21,8 @@
(input ([type "text"] [name "number"] [value ""])) (input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"] [name "enter"] [value "Enter"]))))))) (input ([type "submit"] [name "enter"] [value "Enter"])))))))
`(html (head (title "Sum")) (define (start initial-request)
(body ([bgcolor "white"]) `(html (head (title "Sum"))
(p "The sum is " (body ([bgcolor "white"])
,(number->string (+ (request-number "first") (request-number "second"))))))) (p "The sum is "
,(number->string (+ (request-number "first") (request-number "second"))))))))

20
collects/web-server/default-web-root/servlets/examples/compound/add.ss
View File

@ -1,20 +1,12 @@
(require (lib "unit.ss") (module add mzscheme
(lib "servlet-sig.ss" "web-server") (require "helper.ss")
"helper-sig.ss") (provide (all-defined))
(define interface-version 'v1)
(define main@ (define timeout +inf.0)
(unit
(import servlet^ my-servlet-helpers^)
(export)
(define (start initial-request)
`(html (head (title "Sum")) `(html (head (title "Sum"))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p "The sum is " (p "The sum is "
,(number->string (+ (get-number "the first number to add") ,(number->string (+ (get-number "the first number to add")
(get-number "the second number to add")))))))) (get-number "the second number to add"))))))))
(compound-unit (import (S : servlet^))
(export)
(link
(((H : my-servlet-helpers^)) ((load-relative "helper.ss") S))
(() main@ S H)))

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

@ -1,5 +0,0 @@
(module helper-sig mzscheme
(provide my-servlet-helpers^)
(require (lib "unit.ss"))
(define-signature my-servlet-helpers^ (get-number)))

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

@ -1,11 +1,6 @@
(require (lib "xml.ss" "xml") (module helper mzscheme
(lib "unit.ss") (require (lib "servlet.ss" "web-server"))
(lib "servlet-sig.ss" "web-server") (provide (all-defined))
"helper-sig.ss")
(unit
(import servlet^)
(export my-servlet-helpers^)
; get-number : string -> number ; get-number : string -> number
; to prompt the user for a number ; to prompt the user for a number
@ -20,7 +15,7 @@
(build-suspender (build-suspender
(list prompt) (list prompt)
`(,@error-message `(,@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."))))))))

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

@ -1,84 +1,83 @@
(require (lib "servlet-sig.ss" "web-server") (module multiply mzscheme
(lib "unit.ss") (require (lib "servlet.ss" "web-server")
(lib "etc.ss") (lib "etc.ss")
"helper-sig.ss") "helper.ss")
(provide (all-defined))
(define interface-version 'v1)
(define timeout +inf.0)
(define multiply@ ; matrix = (listof (listof num))
(unit
(import servlet^ my-servlet-helpers^)
(export)
; matrix = (listof (listof num)) ; matrix-multiply : matrix matrix -> matrix
(define (matrix-multiply a b)
(map (lambda (a-row)
(side-map (lambda (b-column)
(apply + (map * a-row b-column)))
b))
a))
; matrix-multiply : matrix matrix -> matrix ; side-map : ((listof a) -> b) (listof (listof a)) -> (listof b)
(define (matrix-multiply a b) (define (side-map f m)
(map (lambda (a-row) (cond
(side-map (lambda (b-column) [(null? (car m)) null]
(apply + (map * a-row b-column))) [else (cons (f (map car m))
b)) (side-map f (map cdr m)))]))
a))
; side-map : ((listof a) -> b) (listof (listof a)) -> (listof b) ; ---
(define (side-map f m)
(cond
[(null? (car m)) null]
[else (cons (f (map car m))
(side-map f (map cdr m)))]))
; --- ; get-dimentions : -> nat nat
; to ask for and return the number of rows and columns
(define (get-dimentions)
(values
(get-number "the number of rows in the first matrix")
(get-number "the number of rows in the second matrix")))
; get-dimentions : -> nat nat ; get-matrix : nat nat -> matrix
; to ask for and return the number of rows and columns (define (get-matrix rows columns)
(define (get-dimentions) (let ([b (get-matrix-bindings rows columns)])
(values (build-list
(get-number "the number of rows in the first matrix") rows
(get-number "the number of rows in the second matrix"))) (lambda (r)
(build-list
columns
(lambda (c)
(string->number (extract-binding/single (string->symbol (field-name r c)) b))))))))
; get-matrix : nat nat -> matrix ; get-matrix-bindings : nat nat -> (listof (cons sym str))
(define (get-matrix rows columns) (define (get-matrix-bindings rows columns)
(let ([b (get-matrix-bindings rows columns)]) (request-bindings
(build-list (send/suspend
rows (build-suspender
(lambda (r) (list "Enter a " (number->string rows) " by "
(build-list (number->string columns) " Matrix")
columns `((table
(lambda (c) . ,(build-list
(string->number (extract-binding/single (string->symbol (field-name r c)) b)))))))) 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"])))))))
; get-matrix-bindings : nat nat -> (listof (cons sym str)) ; field-name : nat nat -> str
(define (get-matrix-bindings rows columns) (define (field-name row column)
(request-bindings (format "x-~a-~a" row column))
(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"])))))))
; field-name : nat nat -> str ; ---
(define (field-name row column)
(format "x-~a-~a" row column))
; --- ; render-matrix : matrix -> html
(define (render-matrix m)
`(table
([border "1"])
. ,(map (lambda (row)
`(tr . ,(map (lambda (n)
`(td ,(number->string n)))
row)))
m)))
; render-matrix : matrix -> html ; main
(define (render-matrix m) (define (start initial-request)
`(table
([border "1"])
. ,(map (lambda (row)
`(tr . ,(map (lambda (n)
`(td ,(number->string n)))
row)))
m)))
; main
`(html (head (title "Matrix Product")) `(html (head (title "Matrix Product"))
(body (body
(p "The matrix product is" (p "The matrix product is"
@ -86,9 +85,3 @@
(let-values ([(r c) (get-dimentions)]) (let-values ([(r c) (get-dimentions)])
(matrix-multiply (get-matrix r c) (matrix-multiply (get-matrix r c)
(get-matrix c r))))))))) (get-matrix c r)))))))))
(compound-unit (import (S : servlet^))
(export)
(link
(((H : my-servlet-helpers^)) ((load-relative "helper.ss") S))
(() multiply@ S H)))

18
collects/web-server/default-web-root/servlets/examples/count.ss
View File

@ -1,11 +1,11 @@
(require (lib "unit.ss") (module count mzscheme
(lib "servlet-sig.ss" "web-server") (require (lib "date.ss"))
(lib "date.ss")) (provide (all-defined))
(define interface-version 'v1)
(let ([count 0] (define timeout +inf.0)
[date (date->string (seconds->date (current-seconds)) 'time-too)]) (define count 0)
(unit (import servlet^) (define a-date (date->string (seconds->date (current-seconds)) 'time-too))
(export) (define (start initial-request)
(define other-count 0) (define other-count 0)
(set! other-count (add1 other-count)) (set! other-count (add1 other-count))
@ -15,4 +15,4 @@
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p "This servlet was called " ,(number->string count) (p "This servlet was called " ,(number->string count)
" times and " ,(number->string other-count) " times and " ,(number->string other-count)
" times since loaded on " ,date "."))))) " times since loaded on " ,a-date ".")))))

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

@ -1,13 +1,11 @@
(require (lib "unit.ss") (module dir mzscheme
(lib "servlet-sig.ss" "web-server") (require (lib "servlet.ss" "web-server"))
(lib "date.ss")) (provide (all-defined))
(define interface-version 'v1)
(unit (import servlet^) (define timeout +inf.0)
(export) (define (start initial-request)
(send/back
(send/back `(html (head (title "Current Directory Page"))
`(html (head (title "Current Directory Page")) (body
(body (h1 "Current Directory Page")
(h1 "Current Directory Page") (p "The current directory is: " (em ,(path->string (current-directory)))))))))
(p "The current directory is: " (em ,(path->string (current-directory))))))))

19
collects/web-server/default-web-root/servlets/examples/hello.ss
View File

@ -1,11 +1,10 @@
(require (lib "unit.ss") (module hello mzscheme
(lib "servlet-sig.ss" "web-server")) (provide (all-defined))
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(define the-text "Hello, Web!")
(unit (import servlet^) `(html (head (title ,the-text))
(export) (body ([bgcolor "white"])
(p ,the-text)))))
(define the-text "Hello, Web!")
`(html (head (title ,the-text))
(body ([bgcolor "white"])
(p ,the-text))))

355
collects/web-server/default-web-root/servlets/examples/quiz.ss
View File

@ -11,198 +11,195 @@
;; choices = (listof string), possible answers to the question ;; choices = (listof string), possible answers to the question
;; correct-answer = integer, index into choices ;; correct-answer = integer, index into choices
;; ;;
(module quiz mzscheme
;; Configuration
(define *data-file*
(build-path (collection-path "web-server")
"default-web-root" "servlets" "examples" "english-measure-questions.ss"))
(define *questions-per-quiz* 5)
;; Configuration (require (lib "servlet.ss" "web-server")
(define *data-file* (lib "list.ss")
(build-path (collection-path "web-server") (lib "etc.ss"))
"default-web-root" "servlets" "examples" "english-measure-questions.ss"))
(define *questions-per-quiz* 5)
(provide (all-defined))
(define interface-version 'v1)
(define timeout +inf.0)
(require (lib "unit.ss") ;; Accessors into question sexp's
(lib "servlet-sig.ss" "web-server") (define question-text car)
(lib "list.ss") (define question-choices cadr)
(lib "etc.ss")) (define question-answer caddr)
(define question-explanation cadddr)
(unit (import servlet^) (define quiz (load *data-file*))
(export) (define quiz-intro (car quiz))
(define all-questions (cadr quiz))
;; Accessors into question sexp's ;; ask-question: question number number -> (listof (cons symbol string))
(define question-text car) ;; Page for asking quiz question.
(define question-choices cadr) ;; result contains a binding for 'answer
(define question-answer caddr) (define (ask-question question-sexp question-number n-questions)
(define question-explanation cadddr) (request-bindings
(send/suspend
(lambda (k-url)
(let ((answer-num -1))
`(html
(head
(title "Quiz Servlet")
(body
(p ,(format "Question ~A of ~A" (add1 question-number)
n-questions))
(p ,(question-text question-sexp))
(form ((method "post") (action ,k-url))
,@(map (lambda (choice)
(set! answer-num (add1 answer-num))
`(p
,(choice-descriptor answer-num) ". "
(input ((type "radio")
(name "answer")
(value ,(number->string
answer-num))))
,choice))
(cadr question-sexp))
(input ((type "submit")
(value "Next"))))))))))))
(define quiz (load *data-file*)) ;; ((listof question-sexp) size) -> (listof question-sexp)
(define quiz-intro (car quiz)) ;; Choose a subset (without duplicates) of given size from a given list
(define all-questions (cadr quiz)) ;; assume subset-size <= (length questions)
(define (random-question-set questions subset-size)
(let choose-questions ([questions questions]
[chosen '()])
(if (= (length chosen) subset-size)
chosen
(let ([qstn (list-ref questions (random (length questions)))])
(choose-questions
(filter
(lambda (q)
(not (eq? qstn q)))
questions)
(cons qstn chosen))))))
;; ask-question: question number number -> (listof (cons symbol string)) ;; choice-descriptor: number -> character
;; Page for asking quiz question. ;; Map 0 to "A", 1 to "B", etc
;; result contains a binding for 'answer (define (choice-descriptor number)
(define (ask-question question-sexp question-number n-questions) (string (integer->char (+ (char->integer #\A) number))))
(request-bindings
;; begin-quiz: -> request
;; request bindings are not currently used
(define (begin-quiz)
(send/suspend (send/suspend
(lambda (k-url) (lambda (k-url)
(let ((answer-num -1)) `(html
`(html (head
(head (title "Quiz Servlet"))
(title "Quiz Servlet") (body
(body (p ,quiz-intro)
(p ,(format "Question ~A of ~A" (add1 question-number) (form ((method "post") (action ,k-url))
n-questions)) (input ((type "submit")
(p ,(question-text question-sexp)) (value "Begin Quiz")))))))))
(form ((method "post") (action ,k-url))
,@(map (lambda (choice)
(set! answer-num (add1 answer-num))
`(p
,(choice-descriptor answer-num) ". "
(input ((type "radio")
(name "answer")
(value ,(number->string
answer-num))))
,choice))
(cadr question-sexp))
(input ((type "submit")
(value "Next"))))))))))))
;; ((listof question-sexp) size) -> (listof question-sexp) ;; Compare list of questions to answers.
;; Choose a subset (without duplicates) of given size from a given list ;; ((listof question-sexp) (listof integer|false)) -> (listof integer)
;; assume subset-size <= (length questions) (define (score-quiz questions answers)
(define (random-question-set questions subset-size) (foldr
(let choose-questions ([questions questions] (lambda (question answer csw)
[chosen '()]) (let ([correct-answer (question-answer question)])
(if (= (length chosen) subset-size) (apply
chosen (lambda (correct skipped wrong)
(let ([qstn (list-ref questions (random (length questions)))]) (cond
(choose-questions [(not answer)
(filter (list correct (add1 skipped) wrong)]
(lambda (q) [(= answer correct-answer)
(not (eq? qstn q))) (list (add1 correct) skipped wrong)]
questions) [else
(cons qstn chosen)))))) (list correct skipped (add1 wrong))]))
csw)))
(list 0 0 0) questions answers))
;; choice-descriptor: number -> character ;; end-quiz: (listof question) (listof (or/c number false)) -> request
;; Map 0 to "A", 1 to "B", etc ;; request bindings are not currently used.
(define (choice-descriptor number) (define (end-quiz questions answers)
(string (integer->char (+ (char->integer #\A) number)))) (send/forward
(lambda (k-url)
(let* ((score (score-quiz questions answers))
(correct (car score))
(skipped (cadr score))
(wrong (caddr score))
(xml
`(html
(head
(title "Quiz Servlet"))
(body
(p ,(format "Your score: ~A/~A"
correct
(+ correct wrong skipped)))
(p ,(format "Correct: ~A" correct))
(p ,(format "Skipped: ~A" skipped))
(p ,(format "Wrong: ~A" wrong))
(table ((border "5"))
(tr (td "Question") (td "Correct Answer")
(td "Your Answer") (td "Explanation"))
,@(map
(lambda (q a)
`(tr
(td ,(question-text q))
(td ,(format "~A. ~A"
(choice-descriptor
(question-answer q))
(list-ref (question-choices q)
(question-answer q))))
(td ,(if a
(format "~A. ~A" (choice-descriptor a)
(list-ref
(question-choices q) a))
"Skipped"))
(td ,(question-explanation q))))
questions answers))
(form ((method "get")
(action ,k-url))
(input ((type "submit")
(value "New Quiz"))))))))
xml))))
;; begin-quiz: -> request ;; Return the first value for key in bindings, if it at least one
;; request bindings are not currently used ;; exists, otherwise #f.
(define (begin-quiz) (define (binding-value key bindings)
(send/suspend (and (exists-binding? key bindings)
(lambda (k-url) (extract-binding/single key bindings)))
`(html
(head
(title "Quiz Servlet"))
(body
(p ,quiz-intro)
(form ((method "post") (action ,k-url))
(input ((type "submit")
(value "Begin Quiz")))))))))
;; Compare list of questions to answers. ;; run-quiz: -> void
;; ((listof question-sexp) (listof integer|false)) -> (listof integer) ;; run quizes until the student gets tired
(define (score-quiz questions answers) (define (run-quiz)
(foldr (let ([*questions-per-quiz*
(lambda (question answer csw) (if (> *questions-per-quiz* (length all-questions))
(let ([correct-answer (question-answer question)]) (begin
(apply (display (format "~A ~A ~A ~A\n"
(lambda (correct skipped wrong) "Configuration error. *questions-per-quiz*:"
(cond *questions-per-quiz*
[(not answer) "for a question list of size"
(list correct (add1 skipped) wrong)] (length all-questions)))
[(= answer correct-answer) (length all-questions))
(list (add1 correct) skipped wrong)] *questions-per-quiz*)])
[else
(list correct skipped (add1 wrong))]))
csw)))
(list 0 0 0) questions answers))
;; end-quiz: (listof question) (listof (or/c number false)) -> request (let ([questions (random-question-set all-questions
;; request bindings are not currently used. *questions-per-quiz*)])
(define (end-quiz questions answers) (begin-quiz)
(send/forward (let ([answers
(lambda (k-url) (build-list (length questions)
(let* ((score (score-quiz questions answers)) (lambda (question-number)
(correct (car score)) (let ([answer
(skipped (cadr score)) (binding-value 'answer
(wrong (caddr score)) (ask-question
(xml (list-ref questions question-number)
`(html question-number
(head *questions-per-quiz*))])
(title "Quiz Servlet")) (and answer (string->number answer)))))])
(body (end-quiz questions answers))))
(p ,(format "Your score: ~A/~A" (run-quiz))
correct
(+ correct wrong skipped)))
(p ,(format "Correct: ~A" correct))
(p ,(format "Skipped: ~A" skipped))
(p ,(format "Wrong: ~A" wrong))
(table ((border "5"))
(tr (td "Question") (td "Correct Answer")
(td "Your Answer") (td "Explanation"))
,@(map
(lambda (q a)
`(tr
(td ,(question-text q))
(td ,(format "~A. ~A"
(choice-descriptor
(question-answer q))
(list-ref (question-choices q)
(question-answer q))))
(td ,(if a
(format "~A. ~A" (choice-descriptor a)
(list-ref
(question-choices q) a))
"Skipped"))
(td ,(question-explanation q))))
questions answers))
(form ((method "get")
(action ,k-url))
(input ((type "submit")
(value "New Quiz"))))))))
xml))))
;; Return the first value for key in bindings, if it at least one
;; exists, otherwise #f.
(define (binding-value key bindings)
(and (exists-binding? key bindings)
(extract-binding/single key bindings)))
;; run-quiz: -> void
;; run quizes until the student gets tired
(define (run-quiz)
(let ([*questions-per-quiz*
(if (> *questions-per-quiz* (length all-questions))
(begin
(display (format "~A ~A ~A ~A\n"
"Configuration error. *questions-per-quiz*:"
*questions-per-quiz*
"for a question list of size"
(length all-questions)))
(length all-questions))
*questions-per-quiz*)])
(let ([questions (random-question-set all-questions
*questions-per-quiz*)])
(begin-quiz)
(let ([answers
(build-list (length questions)
(lambda (question-number)
(let ([answer
(binding-value 'answer
(ask-question
(list-ref questions question-number)
question-number
*questions-per-quiz*))])
(and answer (string->number answer)))))])
(end-quiz questions answers))))
(run-quiz))
;; Entry point into servlet.
(run-quiz)
)
;; Entry point into servlet.
(define (start initial-request)
(run-quiz)))

12
collects/web-server/default-web-root/servlets/tests/bad-return.ss
View File

@ -1,6 +1,6 @@
(require (lib "unit.ss") (module bad-return mzscheme
(lib "servlet-sig.ss" "web-server")) (provide (all-defined))
(unit (define interface-version 'v1)
(import servlet^) (define timeout +inf.0)
(export) (define (start initial-request)
5) 5))

12
collects/web-server/default-web-root/servlets/tests/broken.ss
View File

@ -1,6 +1,6 @@
(require (lib "unit.ss") (module broken mzscheme
(lib "servlet-sig.ss" "web-server")) (provide (all-defined))
(unit (define interface-version 'v1)
(import servlet^) (define timeout +inf.0)
(export) (define (start initial-request)
(raise 'kablooie)) (raise 'kablooie)))

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

@ -1,15 +1,14 @@
(require (lib "servlet-sig.ss" "web-server") (module incremental mzscheme
(lib "unit.ss")) (require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(unit (define interface-version 'v1)
(import servlet^) (define timeout +inf.0)
(export) (define (start initial-request)
(send/finish
(send/finish (make-html-response/incremental
(make-html-response/incremental (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") (output-chunk "<body><p>The first paragraph</p>\n")
(output-chunk "<body><p>The first paragraph</p>\n") (sleep 4)
(sleep 4) (output-chunk "<p>The second paragraph</p></body></html>\n"))))))
(output-chunk "<p>The second paragraph</p></body></html>\n")))))

17
collects/web-server/default-web-root/servlets/tests/mime.ss
View File

@ -1,8 +1,9 @@
(require (lib "unit.ss") (module mime mzscheme
(lib "servlet-sig.ss" "web-server")) (require (lib "servlet.ss" "web-server"))
(unit (provide (all-defined))
(import servlet^) (define interface-version 'v1)
(export) (define timeout +inf.0)
`("text/uber-format" (define (start initial-request)
"uber uber uber" `("text/uber-format"
"-de-doo")) "uber uber uber"
"-de-doo")))

10
collects/web-server/default-web-root/servlets/tests/new-suite/bad-xexpr.ss Normal file
View File

@ -0,0 +1,10 @@
(module bad-xexpr mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start initial-request)
(send/back
`(html (a ([href url])
"Title")))))

14
collects/web-server/default-web-root/servlets/tests/new-suite/bus-error.ss Normal file
View File

@ -0,0 +1,14 @@
(module bus-error mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 120)
(define (end request)
`(html (body "End")))
(define (start request)
(send/suspend/callback
`(html (body (p (a ([href ,start]) "Forward"))
(p (a ([href ,end]) "End")))))))

9
collects/web-server/default-web-root/servlets/tests/new-suite/button.ss Normal file
View File

@ -0,0 +1,9 @@
(module button mzscheme
(require (lib "mred.ss" "mred")
(lib "class.ss"))
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(let ([b (new button% (label "Button"))])
(list #"text/plain" "Button"))))

1
collects/web-server/default-web-root/servlets/tests/new-suite/cell-example.ss Symbolic link
View File

@ -0,0 +1 @@
/Users/jay/Development/Projects/papers/web-cells/cell-example.ss

46
collects/web-server/default-web-root/servlets/tests/new-suite/counter-cells.ss Normal file
View File

@ -0,0 +1,46 @@
(module counter-cells mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start _)
(main-page))
(define the-counter (make-web-cell:local 0))
(define the-header (make-web-cell:local (box "Main page")))
(define (counter)
(send/suspend/dispatch
(lambda (embed/url)
`(html (h2 ,(number->string (web-cell:local-ref the-counter)))
(a ([href ,(embed/url
(lambda _
(web-cell:local-mask the-counter
(add1 (web-cell:local-ref the-counter)))
(counter)))])
"Increment")
(br)
(a ([href ,(embed/url
(lambda _
'exit))])
"Exit")))))
(define (main-page)
(send/suspend/dispatch
(lambda (embed/url)
`(html (h2 ,(unbox (web-cell:local-ref the-header)))
(form ([method "POST"]
[action ,(embed/url
(lambda (req)
(set-box! (web-cell:local-ref the-header)
(extract-binding/single 'header (request-bindings req)))
(main-page)))])
(input ([type "text"] [name "header"]))
(input ([type "submit"])))
(br)
(a ([href ,(embed/url
(lambda _
(counter)
(main-page)))])
"View Counter"))))))

36
collects/web-server/default-web-root/servlets/tests/new-suite/counter-cps.ss Normal file
View File

@ -0,0 +1,36 @@
(module counter-cps mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start _)
(main-page))
(define the-counter (make-parameter 0))
(define (counter k)
(send/suspend/dispatch
(lambda (embed/url)
`(html (h2 ,(number->string (the-counter)))
(a ([href ,(embed/url
(lambda _
(parameterize ([the-counter (add1 (the-counter))])
(counter k))))])
"Increment")
(br)
(a ([href ,(embed/url
(lambda _
(k 'exit)))])
"Exit")))))
(define (main-page)
(send/suspend/dispatch
(lambda (embed/url)
`(html (h2 "Main page")
(a ([href ,(embed/url
(lambda _
(counter
(lambda (v)
(main-page)))))])
"View Counter"))))))

35
collects/web-server/default-web-root/servlets/tests/new-suite/counter.ss Normal file
View File

@ -0,0 +1,35 @@
(module counter mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start _)
(main-page))
(define the-counter (make-parameter 0))
(define (counter)
(send/suspend/dispatch
(lambda (embed/url)
`(html (h2 ,(number->string (the-counter)))
(a ([href ,(embed/url
(lambda _
(parameterize ([the-counter (add1 (the-counter))])
(counter))))])
"Increment")
(br)
(a ([href ,(embed/url
(lambda _
'exit))])
"Exit")))))
(define (main-page)
(send/suspend/dispatch
(lambda (embed/url)
`(html (h2 "Main page")
(a ([href ,(embed/url
(lambda _
(counter)
(main-page)))])
"View Counter"))))))

16
collects/web-server/default-web-root/servlets/tests/new-suite/cust.ss Normal file
View File

@ -0,0 +1,16 @@
(module cust mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define servlet-cust (current-custodian))
(define timeout 30)
(define interface-version 'v1)
(define (start ir)
`(html
(head (title "Custodian test"))
(body
(p ,(if (eq? (current-custodian) servlet-cust)
"It didn't work."
"It did work."))))))

36
collects/web-server/default-web-root/servlets/tests/new-suite/expiration.ss Normal file
View File

@ -0,0 +1,36 @@
(module expiration mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define timeout (* 60 3))
(define interface-version 'v1)
(define (start initial-request)
(parameterize ([current-servlet-continuation-expiration-handler
(lambda (request-for-expired)
(send/back
`(html (body (p "You lose! (Default)")))))])
(let loop ([request initial-request])
(send/suspend/dispatch
(lambda (embed/url)
`(html
(head (title "Expiration demo"))
(body (p "Open each of the links below in a new window. Then click the link in 'Forget' window. Then reload each window.")
(p (a ([href ,(embed/url loop)])
"Loop"))
(p (a ([href ,(embed/url
loop
(lambda (request-for-expired)
(send/back
`(html (head (title "Expiration demo"))
(body (p "You win! (Special)"))))))])
"Loop w/ Expiration"))
(p (a ([href ,(embed/url
(lambda (request)
(loop
(send/forward
(lambda (k-url)
`(html (head (title "Expiration demo"))
(body (p (a ([href ,k-url]) "Forget the past.")))))))))])
"Prepare to forget the past."))))))))))

12
collects/web-server/default-web-root/servlets/tests/new-suite/fault.ss Normal file
View File

@ -0,0 +1,12 @@
(module fault mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 30)
(define X 0)
(define (start request)
(send/suspend
(lambda (k-url)
`(a ([href ,k-url]) "Click")))
(set! X (add1 X))
(format "~a" "fault")))

28
collects/web-server/default-web-root/servlets/tests/new-suite/form.ss Normal file
View File

@ -0,0 +1,28 @@
(module form mzscheme
(require (lib "servlet.ss" "web-server")
(lib "pretty.ss"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start _)
(define req
(send/suspend
(lambda (k-url)
`(html
(body
(form ([action ,k-url] [method "POST"])
(input ([type "checkbox"] [name "checkbox"]))
(input ([type "text"] [name "text"]))
(input ([type "submit"] [name "submit"]))))))))
(define binds
(request-bindings req))
(define sport
(open-output-string))
(define pp
(parameterize ([current-output-port sport])
(pretty-print binds)))
`(html
(body
(pre
,(get-output-string sport))))))

24
collects/web-server/default-web-root/servlets/tests/new-suite/fupload.ss Normal file
View File

@ -0,0 +1,24 @@
(module fupload mzscheme
(require (lib "servlet.ss" "web-server")
(lib "plt-match.ss"))
(provide (all-defined))
(define timeout 60)
(define interface-version 'v1)
(define (start initial-request)
(send/suspend/callback
`(html (head)
(body
(form ([action
,(lambda (request)
(define b (request-bindings/raw request))
(match (bindings-assq #"file" b)
[(struct binding:file (_ filename _))
`(html
(body
,(bytes->string/utf-8 filename)))]))]
[method "post"]
[enctype "multipart/form-data"])
(h3 "Submit for an Assignment")
(input ([name "file"] [type "file"] [size "30"]))
(input ([type "submit"] [value "Submit"]))))))))

15
collects/web-server/default-web-root/servlets/tests/new-suite/hang.ss Normal file
View File

@ -0,0 +1,15 @@
(module hang mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start initial-request)
(send/suspend
(lambda (k-url)
`(html (a ([href ,k-url]) "Next"))))
(send/suspend
(lambda (k-url)
`(html (a ([href ,k-url]) "Error"))))
(/ 1 0)))

19
collects/web-server/default-web-root/servlets/tests/new-suite/hod-0618.ss Normal file
View File

@ -0,0 +1,19 @@
(module hod-0618 mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 30)
(define (start _)
`(html
(body
,(extract-binding/single
'test:case
(request-bindings
(send/suspend
(lambda (k-url)
`(html
(body
(form ([method "POST"]
[action ,k-url])
(input ([type "text"] [name "test:case"]))
(input ([type "submit"])))))))))))))

13
collects/web-server/default-web-root/servlets/tests/new-suite/inf-essence.ss Normal file
View File

@ -0,0 +1,13 @@
(module inf-essence mzscheme
(define a (alarm-evt +inf.0))
(let loop ()
(sync
(handle-evt a
(lambda _
(printf "Infinity has passed.~n")))
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
(* 1000 1)))
(lambda _
(printf "One second has passed.~n"))))
(loop)))

12
collects/web-server/default-web-root/servlets/tests/new-suite/inf.ss Normal file
View File

@ -0,0 +1,12 @@
(module inf mzscheme
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
; start : request -> response
(define (start initial-request)
`(html (head (title "A Test Page"))
(body ([bgcolor "white"])
(p "This is a simple module servlet.")))))

24
collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration-2.ss Normal file
View File

@ -0,0 +1,24 @@
(module instance-expiration-2 mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define timeout 5)
(define interface-version 'v2)
(define (instance-expiration-handler expired-request)
; Not allowed to call any (lib "servlet.ss" "web-server") methods
; (I can't enforce this, however, so if you accidentally do weird things will happen.)
(send/suspend (lambda (k)
`(html (head (title "You win.")) (body "You win.")))))
(define (start initial-request)
(send/suspend/dispatch
(lambda (embed/url)
`(html
(head (title "Instance expiration demo"))
(body (p (a ([href ,(embed/url
(lambda (request)
`(html (head (title "Instance expiration demo"))
(body (p "Reload in a few minutes.")
(p "(or change the instance id to something made up.")))))])
"Click this link."))))))))

23
collects/web-server/default-web-root/servlets/tests/new-suite/instance-expiration.ss Normal file
View File

@ -0,0 +1,23 @@
(module instance-expiration mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define timeout 5)
(define interface-version 'v2)
(define (instance-expiration-handler expired-request)
; Not allowed to call any (lib "servlet.ss" "web-server") methods
; (I can't enforce this, however, so if you accidentally do weird things will happen.)
`(html (head (title "You win.")) (body "You win.")))
(define (start initial-request)
(send/suspend/dispatch
(lambda (embed/url)
`(html
(head (title "Instance expiration demo"))
(body (p (a ([href ,(embed/url
(lambda (request)
`(html (head (title "Instance expiration demo"))
(body (p "Reload in a few minutes.")
(p "(or change the instance id to something made up.")))))])
"Click this link."))))))))

11
collects/web-server/default-web-root/servlets/tests/new-suite/jas01-fix-param.ss Normal file
View File

@ -0,0 +1,11 @@
(module jas01-fix-param mzscheme
(require (lib "servlet.ss" "web-server"))
(provide get-time)
(define load-time
(make-web-cell:local #f))
(define (get-time)
(web-cell:local-ref load-time))
(web-cell:local-set! load-time (current-seconds)))

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

@ -0,0 +1,14 @@
(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))))))

9
collects/web-server/default-web-root/servlets/tests/new-suite/jas01-param.ss Normal file
View File

@ -0,0 +1,9 @@
(module jas01-param mzscheme
(provide get-time)
(define load-time (make-parameter #f))
(define (get-time)
(load-time))
(load-time (current-seconds)))

10
collects/web-server/default-web-root/servlets/tests/new-suite/jas01-test.ss Normal file
View File

@ -0,0 +1,10 @@
(module jas01-test mzscheme
(define start #f)
(thread-wait
(thread
(lambda ()
(set! start (dynamic-require "jas01.ss" 'start)))))
(thread-wait
(thread
(lambda ()
(printf "~S~n" (start 'foo))))))

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

@ -0,0 +1,14 @@
(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))))))

24
collects/web-server/default-web-root/servlets/tests/new-suite/lock.ss Normal file
View File

@ -0,0 +1,24 @@
(module lock mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v2-transitional)
(define timeout 60)
(define (instance-expiration-handler _)
`(html (body "Error")))
(define (start _)
(send/suspend/dispatch
(lambda (embed/url)
`(html (body
(p (a ([href ,(embed/url
(lambda _
(sleep 5)
(second "Slow")))])
"Slow"))
(p (a ([href ,(embed/url
(lambda _
(second "Fast")))])
"Fast")))))))
(define (second label)
`(html (body ,label
,(number->string (current-seconds))))))

10
collects/web-server/default-web-root/servlets/tests/new-suite/none-test.ss Normal file
View File

@ -0,0 +1,10 @@
(module none-test mzscheme
(require (lib "none.ss" "web-server" "managers"))
(provide (all-defined))
(define interface-version 'v2-transitional)
(define manager (create-none-manager
(lambda (failed-request)
`(html (body (h2 "Error"))))))
(define (start initial-request)
`(html (body (h2 "Look Ma, No Instance!")))))

28
collects/web-server/default-web-root/servlets/tests/new-suite/plus.ss Normal file
View File

@ -0,0 +1,28 @@
(module plus mzscheme
(require (lib "servlet.ss" "web-server")
(lib "pretty.ss"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start _)
(define req
(send/suspend
(lambda (k-url)
`(html
(body
(form ([action ,k-url] [method "POST"])
(input ([type "checkbox"] [name "checkbox"]))
(input ([type "text"] [name "text+foo"]))
(input ([type "submit"] [name "submit"]))))))))
(define binds
(request-bindings req))
(define sport
(open-output-string))
(define pp
(parameterize ([current-output-port sport])
(pretty-print binds)))
`(html
(body
(pre
,(get-output-string sport))))))

8
collects/web-server/default-web-root/servlets/tests/new-suite/pr5490.ss Normal file
View File

@ -0,0 +1,8 @@
(module pr5490 mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 120)
(define (start ireq)
(send/finish '(("paul") "..."))))

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

@ -0,0 +1,19 @@
(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)))))

12
collects/web-server/default-web-root/servlets/tests/new-suite/pr7359.ss Normal file
View File

@ -0,0 +1,12 @@
(module pr7359 mzscheme
(require (lib "serialize.ss")
(lib "servlet.ss" "web-server"))
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define-serializable-struct foo ())
(define (start req)
(deserialize (serialize (make-foo)))
`(html (body "Made it"))))

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

@ -0,0 +1,19 @@
(module pr7533 mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start initial-request)
(define start-time (current-seconds))
(let loop ((last-time start-time))
(let ((time (current-seconds)))
(send/suspend
(lambda (k)
`(html
(form ((action ,k) (method "post"))
(p ,(format "It has been ~a seconds since starting (~a seconds since last iteration)."
(- time start-time)
(- time last-time)))
(input ((type "submit")))))))
(loop time)))))

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

@ -0,0 +1,10 @@
(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)))

18
collects/web-server/default-web-root/servlets/tests/new-suite/ssd.ss Normal file
View File

@ -0,0 +1,18 @@
(module ssd mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 120)
(define (start ir)
(printf "X~n")
(send/suspend/dispatch
(lambda (embed/url)
`(html (head)
(body
(ul
,@(map (lambda (i)
`(li (a ([href ,(embed/url
(lambda (r)
`(html (head) (body ,i))))])
,(number->string i))))
`(1 2 3 4 5 6 7 8 9 0)))))))))

9
collects/web-server/default-web-root/servlets/tests/new-suite/static.ss Normal file
View File

@ -0,0 +1,9 @@
(module static mzscheme
(require (lib "servlet.ss" "web-server"))
(provide interface-version timeout start)
(define interface-version 'v1)
(define timeout +inf.0)
(define (start initial-request)
(list
#"text/html"
"<html><head></head><body>Foo</body><html>")))

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

@ -0,0 +1,11 @@
(module update mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define timeout 60)
(define interface-version 'v1)
(define (start initial-request)
(send/back
`(html (head)
(body
(h1 "Hey"))))))

17
collects/web-server/default-web-root/servlets/tests/new-suite/utf8.ss Normal file
View File

@ -0,0 +1,17 @@
(module utf8 mzscheme
(require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(define interface-version 'v1)
(define timeout 60)
(define (start initial-request)
(extract-binding/single
'name
(request-bindings
(send/suspend
(lambda (k-url)
`(html
(body
(form ([action ,k-url])
(input ([type "text"] [name "name"]))
(input ([type "submit"])))))))))))

30
collects/web-server/default-web-root/servlets/tests/size.ss
View File

@ -1,19 +1,19 @@
(require (lib "unit.ss") (module size mzscheme
(lib "servlet-sig.ss" "web-server")) (require (lib "servlet.ss" "web-server"))
(provide (all-defined))
(let* ([line-size 80] (define interface-version 'v1)
[build-a-str (define timeout +inf.0)
(lambda (n)
(list->string (let loop ([n n])
(cond
[(zero? n) (list #\newline)]
[else (cons #\a (loop (sub1 n)))]))))]
[line (build-a-str (sub1 line-size))]
[html-overhead 68])
(unit
(import servlet^)
(export)
(define line-size 80)
(define (build-a-str n)
(list->string (let loop ([n n])
(cond
[(zero? n) (list #\newline)]
[else (cons #\a (loop (sub1 n)))]))))
(define line (build-a-str (sub1 line-size)))
(define html-overhead 68)
(define (start initial-request)
(define bindings (request-bindings initial-request))
(define size (- (string->number (cdr (assq 'size bindings))) html-overhead)) (define size (- (string->number (cdr (assq 'size bindings))) html-overhead))
(define nlines (quotient size line-size)) (define nlines (quotient size line-size))
(define extra (remainder size line-size)) (define extra (remainder size line-size))

14
collects/web-server/default-web-root/servlets/tests/test.ss
View File

@ -1,9 +1,11 @@
(require (lib "unit.ss") (module test mzscheme
(lib "servlet-sig.ss" "web-server")) (require (lib "servlet.ss" "web-server"))
(let ([count 0]) (provide (all-defined))
(unit (define interface-version 'v1)
(import servlet^) (define timeout +inf.0)
(export) (define count 0)
(define (start initial-request)
(with-handlers ([void (lambda (exn) `(html (body (p ,(exn-message exn)))))]) (with-handlers ([void (lambda (exn) `(html (body (p ,(exn-message exn)))))])
(set! count (add1 count)) (set! count (add1 count))
`(html (head (title "Testing 1...2...3")) `(html (head (title "Testing 1...2...3"))

17
collects/web-server/default-web-root/servlets/tests/url.ss
View File

@ -1,10 +1,13 @@
(require (lib "unit.ss") (module url mzscheme
(lib "servlet-sig.ss" "web-server") (require (lib "servlet.ss" "web-server")
(lib "url.ss" "net")) (lib "url.ss" "net"))
(let ([count 0]) (provide (all-defined))
(unit (define interface-version 'v1)
(import servlet^) (define timeout +inf.0)
(export)
(define count 0)
(define (start initial-request)
(set! count (add1 count)) (set! count (add1 count))
`(html (head (title "URL Test")) `(html (head (title "URL Test"))
(body (p "The method requested is: " ,(format "~s" (request-method initial-request))) (body (p "The method requested is: " ,(format "~s" (request-method initial-request)))

22
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -2,7 +2,6 @@
(require (lib "url.ss" "net") (require (lib "url.ss" "net")
(lib "kw.ss") (lib "kw.ss")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "unit.ss")
(lib "string.ss") (lib "string.ss")
(lib "contract.ss")) (lib "contract.ss"))
(require "dispatch.ss" (require "dispatch.ss"
@ -11,7 +10,6 @@
"../private/response.ss" "../private/response.ss"
"../response-structs.ss" "../response-structs.ss"
"../servlet.ss" "../servlet.ss"
"../sig.ss"
"../private/configuration.ss" "../private/configuration.ss"
"../private/util.ss" "../private/util.ss"
"../managers/manager.ss" "../managers/manager.ss"
@ -308,14 +306,6 @@
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.) ;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
;;;; A response ;;;; A response
(define (load-servlet/path a-path) (define (load-servlet/path a-path)
(define (v0.servlet->v1.lambda servlet)
(lambda (initial-request)
(define servlet@ (unit-from-context servlet^))
(invoke-unit
(compound-unit
(import) (export)
(link (((S : servlet^)) servlet@)
(() servlet S))))))
(define (v0.response->v1.lambda response-path response) (define (v0.response->v1.lambda response-path response)
(define go (define go
(box (box
@ -333,16 +323,6 @@
; XXX load/use-compiled breaks errortrace ; XXX load/use-compiled breaks errortrace
(define s (load/use-compiled a-path)) (define s (load/use-compiled a-path))
(cond (cond
;; signed-unit servlet
; MF: I'd also like to test that s has the correct import signature.
[(unit? s)
(make-servlet (current-custodian)
(current-namespace)
(create-timeout-manager
default-servlet-instance-expiration-handler
timeouts-servlet-connection
timeouts-default-servlet)
(v0.servlet->v1.lambda s))]
; FIX - reason about exceptions from dynamic require (catch and report if not already) ; FIX - reason about exceptions from dynamic require (catch and report if not already)
;; module servlet ;; module servlet
[(void? s) [(void? s)
@ -359,7 +339,7 @@
timeouts-servlet-connection timeouts-servlet-connection
timeout) timeout)
(v1.module->v1.lambda timeout start)))] (v1.module->v1.lambda timeout start)))]
[(v2-transitional) ; XXX: Undocumented [(v2 v2-transitional) ; XXX: Undocumented
(let ([start (dynamic-require module-name 'start)] (let ([start (dynamic-require module-name 'start)]
[manager (with-handlers [manager (with-handlers
([exn:fail:contract? ([exn:fail:contract?

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

File diff suppressed because it is too large Load Diff

8
collects/web-server/sig.ss
View File

@ -3,13 +3,7 @@
(require "private/dispatch-server-sig.ss") (require "private/dispatch-server-sig.ss")
(provide ; XXX contract signature (provide ; XXX contract signature
(rename dispatch-server^ web-server^) (rename dispatch-server^ web-server^)
servlet^ web-config^ web-config/pervasive^ web-config/local^) web-config^ web-config/pervasive^ web-config/local^)
#;(define-signature web-server^
((open dispatch-server^)))
(define-signature servlet^
(initial-request send/suspend send/finish send/back send/forward adjust-timeout!))
; more here - rename ; more here - rename
(define-signature web-config/pervasive^ (define-signature web-config/pervasive^