Removing unit servlets
svn: r6101
This commit is contained in:
Jay McCarthy
parent
ea004857cf
commit
00f2c671a3
|
|
@ -1,9 +1,8 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
(lib "date.ss"))
|
||||
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
(module add mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
; request-number : str -> num
|
||||
(define (request-number which-number)
|
||||
|
|
@ -22,9 +21,10 @@
|
|||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"] [name "enter"] [value "Enter"])))))))
|
||||
|
||||
(send/suspend
|
||||
(lambda (k-url)
|
||||
`(html (head (title "Sum"))
|
||||
(body ([bgcolor "white"])
|
||||
(p "The sum is "
|
||||
,(number->string (+ (request-number "first") (request-number "second")))))))))
|
||||
(define (start initial-request)
|
||||
(send/suspend
|
||||
(lambda (k-url)
|
||||
`(html (head (title "Sum"))
|
||||
(body ([bgcolor "white"])
|
||||
(p "The sum is "
|
||||
,(number->string (+ (request-number "first") (request-number "second"))))))))))
|
||||
|
|
@ -1,15 +1,15 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
(lib "date.ss"))
|
||||
|
||||
(let ([count 0]
|
||||
[date (date->string (seconds->date (current-seconds)) 'time-too)])
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
(module count mzscheme
|
||||
(require (lib "date.ss"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
(define count 0)
|
||||
(define a-date (date->string (seconds->date (current-seconds)) 'time-too))
|
||||
(define (start initial-request)
|
||||
(set! count (add1 count))
|
||||
|
||||
(set! count (add1 count))
|
||||
|
||||
`(html (head (title "Counter"))
|
||||
(body ([bgcolor "white"])
|
||||
(p "This servlet was called " ,(number->string count)
|
||||
" times since loaded on " ,date ".")))))
|
||||
`(html (head (title "Counter"))
|
||||
(body ([bgcolor "white"])
|
||||
(p "This servlet was called " ,(number->string count)
|
||||
" times since loaded on " ,a-date ".")))))
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
(module hello mzscheme
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
(define the-text "Hello, Web!")
|
||||
|
||||
`(html (head (title ,the-text))
|
||||
(body ([bgcolor "white"])
|
||||
(p ,the-text))))
|
||||
(define (start initial-request)
|
||||
`(html (head (title ,the-text))
|
||||
(body ([bgcolor "white"])
|
||||
(p ,the-text)))))
|
||||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
A servlet is a <code>unit/sig</code> that imports the <code>servlet^</code>
|
||||
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>
|
||||
(require (lib "unitsig.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
(unit/sig ()
|
||||
(import servlet^)
|
||||
</pre> ...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:
|
||||
</p><ul><li>an <code>X-expression</code> representing HTML <br />
|
||||
(Search for XML in <code>help-desk</code>.)</li><li>a <code>(listof string)</code> where
|
||||
<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
|
||||
<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
|
||||
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 <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
|
||||
<ul><li> method : <code>(Union 'get 'post)</code></li><li> uri : <code>URL</code> <br />
|
||||
see the <code>net</code> collection in <code>help-desk</code> for details</li><li> headers : <code>(listof (cons symbol string))</code> <br />
|
||||
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 -> Response) -> 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.
|
||||
<!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 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.</p>
|
||||
|
||||
<ul><li><code>send/finish : Response -></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 -> Void</code><br />
|
||||
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
|
||||
while smaller numbers force servlet users to restart computations more often.
|
||||
</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)) -> 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)) -> (listof str)returns a list of values assocaited with the name sym.</li><li><code>extract-user-pass : (listof (cons sym str)) -> (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>
|
||||
<p>A servlet is a <code>module</code> that provides
|
||||
three values: an
|
||||
<code>interface-version</code>,
|
||||
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>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
; unless you never want to reconfigure the Web server again.
|
||||
; The servlet accepts requests only from the *same machine* as the Web server
|
||||
; for security purposes.
|
||||
|
||||
(require (lib "configure.ss" "web-server" "private"))
|
||||
|
||||
servlet
|
||||
(module configure mzscheme
|
||||
(require (lib "configure.ss" "web-server" "private"))
|
||||
(provide (all-from (lib "configure.ss" "web-server" "private"))))
|
||||
|
|
@ -1,17 +1,16 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
(lib "date.ss"))
|
||||
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
|
||||
(module add mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
; request-number : str -> num
|
||||
(define (request-number which-number)
|
||||
(string->number
|
||||
(extract-binding/single
|
||||
'number
|
||||
(request-bindings (send/suspend (build-request-page which-number))))))
|
||||
|
||||
|
||||
; build-request-page : str -> str -> response
|
||||
(define (build-request-page which-number)
|
||||
(lambda (k-url)
|
||||
|
|
@ -21,8 +20,9 @@
|
|||
"Enter the " ,which-number " number to add: "
|
||||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"] [name "enter"] [value "Enter"])))))))
|
||||
|
||||
`(html (head (title "Sum"))
|
||||
(body ([bgcolor "white"])
|
||||
(p "The sum is "
|
||||
,(number->string (+ (request-number "first") (request-number "second")))))))
|
||||
|
||||
(define (start initial-request)
|
||||
`(html (head (title "Sum"))
|
||||
(body ([bgcolor "white"])
|
||||
(p "The sum is "
|
||||
,(number->string (+ (request-number "first") (request-number "second"))))))))
|
||||
|
|
@ -1,20 +1,12 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
"helper-sig.ss")
|
||||
|
||||
(define main@
|
||||
(unit
|
||||
(import servlet^ my-servlet-helpers^)
|
||||
(export)
|
||||
|
||||
(module add mzscheme
|
||||
(require "helper.ss")
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
(define (start initial-request)
|
||||
`(html (head (title "Sum"))
|
||||
(body ([bgcolor "white"])
|
||||
(p "The sum is "
|
||||
,(number->string (+ (get-number "the first 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)))
|
||||
(get-number "the second number to add"))))))))
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
(module helper-sig mzscheme
|
||||
(provide my-servlet-helpers^)
|
||||
(require (lib "unit.ss"))
|
||||
|
||||
(define-signature my-servlet-helpers^ (get-number)))
|
||||
|
|
@ -1,11 +1,6 @@
|
|||
(require (lib "xml.ss" "xml")
|
||||
(lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
"helper-sig.ss")
|
||||
|
||||
(unit
|
||||
(import servlet^)
|
||||
(export my-servlet-helpers^)
|
||||
(module helper mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
|
||||
; get-number : string -> number
|
||||
; to prompt the user for a number
|
||||
|
|
@ -20,7 +15,7 @@
|
|||
(build-suspender
|
||||
(list prompt)
|
||||
`(,@error-message
|
||||
(p ,prompt (input ([type "text"] [name "n"])))
|
||||
(input ([type "submit"] [value "Okay"]))))))))]
|
||||
(p ,prompt (input ([type "text"] [name "n"])))
|
||||
(input ([type "submit"] [value "Okay"]))))))))]
|
||||
[n (string->number n-str)])
|
||||
(or n (ask `((p (font ([color "red"]) ,n-str) " is not a number. Please enter a number."))))))))
|
||||
|
|
@ -1,94 +1,87 @@
|
|||
(require (lib "servlet-sig.ss" "web-server")
|
||||
(lib "unit.ss")
|
||||
(lib "etc.ss")
|
||||
"helper-sig.ss")
|
||||
|
||||
(define multiply@
|
||||
(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))
|
||||
|
||||
; 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-matrix : nat nat -> matrix
|
||||
(define (get-matrix rows columns)
|
||||
(let ([b (get-matrix-bindings rows columns)])
|
||||
(build-list
|
||||
rows
|
||||
(lambda (r)
|
||||
(build-list
|
||||
columns
|
||||
(lambda (c)
|
||||
(string->number (extract-binding/single (string->symbol (field-name r c)) b))))))))
|
||||
|
||||
; get-matrix-bindings : nat nat -> (listof (cons sym str))
|
||||
(define (get-matrix-bindings rows columns)
|
||||
(request-bindings
|
||||
(send/suspend
|
||||
(build-suspender
|
||||
(list "Enter a " (number->string rows) " by "
|
||||
(number->string columns) " Matrix")
|
||||
`((table
|
||||
. ,(build-list
|
||||
rows
|
||||
(lambda (r)
|
||||
`(tr . ,(build-list
|
||||
columns
|
||||
(lambda (c)
|
||||
`(td (input ([type "text"] [name ,(field-name r c)])))))))))
|
||||
(input ([type "submit"] [name "submit"] [value "Okay"])))))))
|
||||
|
||||
; 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)))
|
||||
|
||||
; main
|
||||
(module multiply mzscheme
|
||||
(require (lib "servlet.ss" "web-server")
|
||||
(lib "etc.ss")
|
||||
"helper.ss")
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
; 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))
|
||||
|
||||
; 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-matrix : nat nat -> matrix
|
||||
(define (get-matrix rows columns)
|
||||
(let ([b (get-matrix-bindings rows columns)])
|
||||
(build-list
|
||||
rows
|
||||
(lambda (r)
|
||||
(build-list
|
||||
columns
|
||||
(lambda (c)
|
||||
(string->number (extract-binding/single (string->symbol (field-name r c)) b))))))))
|
||||
|
||||
; get-matrix-bindings : nat nat -> (listof (cons sym str))
|
||||
(define (get-matrix-bindings rows columns)
|
||||
(request-bindings
|
||||
(send/suspend
|
||||
(build-suspender
|
||||
(list "Enter a " (number->string rows) " by "
|
||||
(number->string columns) " Matrix")
|
||||
`((table
|
||||
. ,(build-list
|
||||
rows
|
||||
(lambda (r)
|
||||
`(tr . ,(build-list
|
||||
columns
|
||||
(lambda (c)
|
||||
`(td (input ([type "text"] [name ,(field-name r c)])))))))))
|
||||
(input ([type "submit"] [name "submit"] [value "Okay"])))))))
|
||||
|
||||
; 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)))
|
||||
|
||||
; main
|
||||
(define (start initial-request)
|
||||
`(html (head (title "Matrix Product"))
|
||||
(body
|
||||
(p "The matrix product is"
|
||||
,(render-matrix
|
||||
(let-values ([(r c) (get-dimentions)])
|
||||
(matrix-multiply (get-matrix r c)
|
||||
(get-matrix c r)))))))))
|
||||
|
||||
(compound-unit (import (S : servlet^))
|
||||
(export)
|
||||
(link
|
||||
(((H : my-servlet-helpers^)) ((load-relative "helper.ss") S))
|
||||
(() multiply@ S H)))
|
||||
(get-matrix c r)))))))))
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
(lib "date.ss"))
|
||||
|
||||
(let ([count 0]
|
||||
[date (date->string (seconds->date (current-seconds)) 'time-too)])
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
(module count mzscheme
|
||||
(require (lib "date.ss"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define count 0)
|
||||
(define a-date (date->string (seconds->date (current-seconds)) 'time-too))
|
||||
(define (start initial-request)
|
||||
(define other-count 0)
|
||||
|
||||
(set! other-count (add1 other-count))
|
||||
|
|
@ -15,4 +15,4 @@
|
|||
(body ([bgcolor "white"])
|
||||
(p "This servlet was called " ,(number->string count)
|
||||
" times and " ,(number->string other-count)
|
||||
" times since loaded on " ,date ".")))))
|
||||
" times since loaded on " ,a-date ".")))))
|
||||
|
|
@ -1,13 +1,11 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
(lib "date.ss"))
|
||||
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
|
||||
(send/back
|
||||
`(html (head (title "Current Directory Page"))
|
||||
(body
|
||||
(h1 "Current Directory Page")
|
||||
(p "The current directory is: " (em ,(path->string (current-directory))))))))
|
||||
|
||||
(module dir mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define (start initial-request)
|
||||
(send/back
|
||||
`(html (head (title "Current Directory Page"))
|
||||
(body
|
||||
(h1 "Current Directory Page")
|
||||
(p "The current directory is: " (em ,(path->string (current-directory)))))))))
|
||||
|
|
@ -1,11 +1,10 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
|
||||
(define the-text "Hello, Web!")
|
||||
|
||||
`(html (head (title ,the-text))
|
||||
(body ([bgcolor "white"])
|
||||
(p ,the-text))))
|
||||
(module hello mzscheme
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define (start initial-request)
|
||||
(define the-text "Hello, Web!")
|
||||
|
||||
`(html (head (title ,the-text))
|
||||
(body ([bgcolor "white"])
|
||||
(p ,the-text)))))
|
||||
|
|
@ -11,198 +11,195 @@
|
|||
;; choices = (listof string), possible answers to the question
|
||||
;; correct-answer = integer, index into choices
|
||||
;;
|
||||
|
||||
;; Configuration
|
||||
(define *data-file*
|
||||
(build-path (collection-path "web-server")
|
||||
"default-web-root" "servlets" "examples" "english-measure-questions.ss"))
|
||||
(define *questions-per-quiz* 5)
|
||||
|
||||
|
||||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss"))
|
||||
|
||||
(unit (import servlet^)
|
||||
(export)
|
||||
|
||||
;; Accessors into question sexp's
|
||||
(define question-text car)
|
||||
(define question-choices cadr)
|
||||
(define question-answer caddr)
|
||||
(define question-explanation cadddr)
|
||||
|
||||
(define quiz (load *data-file*))
|
||||
(define quiz-intro (car quiz))
|
||||
(define all-questions (cadr quiz))
|
||||
|
||||
;; ask-question: question number number -> (listof (cons symbol string))
|
||||
;; Page for asking quiz question.
|
||||
;; result contains a binding for 'answer
|
||||
(define (ask-question question-sexp question-number n-questions)
|
||||
(request-bindings
|
||||
(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)
|
||||
|
||||
(require (lib "servlet.ss" "web-server")
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss"))
|
||||
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
;; Accessors into question sexp's
|
||||
(define question-text car)
|
||||
(define question-choices cadr)
|
||||
(define question-answer caddr)
|
||||
(define question-explanation cadddr)
|
||||
|
||||
(define quiz (load *data-file*))
|
||||
(define quiz-intro (car quiz))
|
||||
(define all-questions (cadr quiz))
|
||||
|
||||
;; ask-question: question number number -> (listof (cons symbol string))
|
||||
;; Page for asking quiz question.
|
||||
;; result contains a binding for 'answer
|
||||
(define (ask-question question-sexp question-number n-questions)
|
||||
(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"))))))))))))
|
||||
|
||||
;; ((listof question-sexp) size) -> (listof question-sexp)
|
||||
;; Choose a subset (without duplicates) of given size from a given list
|
||||
;; 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))))))
|
||||
|
||||
;; choice-descriptor: number -> character
|
||||
;; Map 0 to "A", 1 to "B", etc
|
||||
(define (choice-descriptor number)
|
||||
(string (integer->char (+ (char->integer #\A) number))))
|
||||
|
||||
;; begin-quiz: -> request
|
||||
;; request bindings are not currently used
|
||||
(define (begin-quiz)
|
||||
(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"))))))))))))
|
||||
|
||||
;; ((listof question-sexp) size) -> (listof question-sexp)
|
||||
;; Choose a subset (without duplicates) of given size from a given list
|
||||
;; 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))))))
|
||||
|
||||
;; choice-descriptor: number -> character
|
||||
;; Map 0 to "A", 1 to "B", etc
|
||||
(define (choice-descriptor number)
|
||||
(string (integer->char (+ (char->integer #\A) number))))
|
||||
|
||||
;; begin-quiz: -> request
|
||||
;; request bindings are not currently used
|
||||
(define (begin-quiz)
|
||||
(send/suspend
|
||||
(lambda (k-url)
|
||||
`(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.
|
||||
;; ((listof question-sexp) (listof integer|false)) -> (listof integer)
|
||||
(define (score-quiz questions answers)
|
||||
(foldr
|
||||
(lambda (question answer csw)
|
||||
(let ([correct-answer (question-answer question)])
|
||||
(apply
|
||||
(lambda (correct skipped wrong)
|
||||
(cond
|
||||
[(not answer)
|
||||
(list correct (add1 skipped) wrong)]
|
||||
[(= answer correct-answer)
|
||||
(list (add1 correct) skipped wrong)]
|
||||
[else
|
||||
(list correct skipped (add1 wrong))]))
|
||||
csw)))
|
||||
(list 0 0 0) questions answers))
|
||||
|
||||
;; end-quiz: (listof question) (listof (or/c number false)) -> request
|
||||
;; request bindings are not currently used.
|
||||
(define (end-quiz questions answers)
|
||||
(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))))
|
||||
|
||||
;; 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)
|
||||
|
||||
)
|
||||
|
||||
`(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.
|
||||
;; ((listof question-sexp) (listof integer|false)) -> (listof integer)
|
||||
(define (score-quiz questions answers)
|
||||
(foldr
|
||||
(lambda (question answer csw)
|
||||
(let ([correct-answer (question-answer question)])
|
||||
(apply
|
||||
(lambda (correct skipped wrong)
|
||||
(cond
|
||||
[(not answer)
|
||||
(list correct (add1 skipped) wrong)]
|
||||
[(= answer correct-answer)
|
||||
(list (add1 correct) skipped wrong)]
|
||||
[else
|
||||
(list correct skipped (add1 wrong))]))
|
||||
csw)))
|
||||
(list 0 0 0) questions answers))
|
||||
|
||||
;; end-quiz: (listof question) (listof (or/c number false)) -> request
|
||||
;; request bindings are not currently used.
|
||||
(define (end-quiz questions answers)
|
||||
(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))))
|
||||
|
||||
;; 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.
|
||||
(define (start initial-request)
|
||||
(run-quiz)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
(unit
|
||||
(import servlet^)
|
||||
(export)
|
||||
5)
|
||||
(module bad-return mzscheme
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define (start initial-request)
|
||||
5))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
(unit
|
||||
(import servlet^)
|
||||
(export)
|
||||
(raise 'kablooie))
|
||||
(module broken mzscheme
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define (start initial-request)
|
||||
(raise 'kablooie)))
|
||||
|
|
@ -1,15 +1,14 @@
|
|||
(require (lib "servlet-sig.ss" "web-server")
|
||||
(lib "unit.ss"))
|
||||
|
||||
(unit
|
||||
(import servlet^)
|
||||
(export)
|
||||
|
||||
(send/finish
|
||||
(make-html-response/incremental
|
||||
(lambda (output-chunk)
|
||||
(output-chunk "<html><head><title>"
|
||||
"my-title</title></head>\n")
|
||||
(output-chunk "<body><p>The first paragraph</p>\n")
|
||||
(sleep 4)
|
||||
(output-chunk "<p>The second paragraph</p></body></html>\n")))))
|
||||
(module incremental mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define (start initial-request)
|
||||
(send/finish
|
||||
(make-html-response/incremental
|
||||
(lambda (output-chunk)
|
||||
(output-chunk "<html><head><title>"
|
||||
"my-title</title></head>\n")
|
||||
(output-chunk "<body><p>The first paragraph</p>\n")
|
||||
(sleep 4)
|
||||
(output-chunk "<p>The second paragraph</p></body></html>\n"))))))
|
||||
|
|
@ -1,8 +1,9 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
(unit
|
||||
(import servlet^)
|
||||
(export)
|
||||
`("text/uber-format"
|
||||
"uber uber uber"
|
||||
"-de-doo"))
|
||||
(module mime mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define (start initial-request)
|
||||
`("text/uber-format"
|
||||
"uber uber uber"
|
||||
"-de-doo")))
|
||||
|
|
@ -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")))))
|
||||
|
|
@ -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")))))))
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -0,0 +1 @@
|
|||
/Users/jay/Development/Projects/papers/web-cells/cell-example.ss
|
||||
|
|
@ -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"))))))
|
||||
|
|
@ -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"))))))
|
||||
|
|
@ -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"))))))
|
||||
|
|
@ -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."))))))
|
||||
|
||||
|
|
@ -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."))))))))))
|
||||
|
||||
|
|
@ -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")))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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"]))))))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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"])))))))))))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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.")))))
|
||||
|
|
@ -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."))))))))
|
||||
|
|
@ -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."))))))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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!")))))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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") "..."))))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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"))))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)))))))))
|
||||
|
|
@ -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>")))
|
||||
|
|
@ -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"))))))
|
||||
|
|
@ -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"])))))))))))
|
||||
|
|
@ -1,23 +1,23 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
|
||||
(let* ([line-size 80]
|
||||
[build-a-str
|
||||
(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)
|
||||
|
||||
(module size mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
(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 nlines (quotient size line-size))
|
||||
(define extra (remainder size line-size))
|
||||
|
||||
`(html (head (title "A Page"))
|
||||
(body (p ,@(vector->list (make-vector nlines line))
|
||||
,(build-a-str extra))))))
|
||||
,(build-a-str extra))))))
|
||||
|
|
@ -1,9 +1,11 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server"))
|
||||
(let ([count 0])
|
||||
(unit
|
||||
(import servlet^)
|
||||
(export)
|
||||
(module test mzscheme
|
||||
(require (lib "servlet.ss" "web-server"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
(define count 0)
|
||||
|
||||
(define (start initial-request)
|
||||
(with-handlers ([void (lambda (exn) `(html (body (p ,(exn-message exn)))))])
|
||||
(set! count (add1 count))
|
||||
`(html (head (title "Testing 1...2...3"))
|
||||
|
|
@ -12,4 +14,4 @@
|
|||
(br)
|
||||
"Count = " ,(number->string count)
|
||||
(br)
|
||||
,(format "Here are the headers:~n~s~n" (request-headers initial-request))))))))
|
||||
,(format "Here are the headers:~n~s~n" (request-headers initial-request))))))))
|
||||
|
|
@ -1,10 +1,13 @@
|
|||
(require (lib "unit.ss")
|
||||
(lib "servlet-sig.ss" "web-server")
|
||||
(lib "url.ss" "net"))
|
||||
(let ([count 0])
|
||||
(unit
|
||||
(import servlet^)
|
||||
(export)
|
||||
(module url mzscheme
|
||||
(require (lib "servlet.ss" "web-server")
|
||||
(lib "url.ss" "net"))
|
||||
(provide (all-defined))
|
||||
(define interface-version 'v1)
|
||||
(define timeout +inf.0)
|
||||
|
||||
(define count 0)
|
||||
|
||||
(define (start initial-request)
|
||||
(set! count (add1 count))
|
||||
`(html (head (title "URL Test"))
|
||||
(body (p "The method requested is: " ,(format "~s" (request-method initial-request)))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@
|
|||
(require (lib "url.ss" "net")
|
||||
(lib "kw.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "string.ss")
|
||||
(lib "contract.ss"))
|
||||
(require "dispatch.ss"
|
||||
|
|
@ -11,7 +10,6 @@
|
|||
"../private/response.ss"
|
||||
"../response-structs.ss"
|
||||
"../servlet.ss"
|
||||
"../sig.ss"
|
||||
"../private/configuration.ss"
|
||||
"../private/util.ss"
|
||||
"../managers/manager.ss"
|
||||
|
|
@ -308,14 +306,6 @@
|
|||
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
|
||||
;;;; A response
|
||||
(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 go
|
||||
(box
|
||||
|
|
@ -333,16 +323,6 @@
|
|||
; XXX load/use-compiled breaks errortrace
|
||||
(define s (load/use-compiled a-path))
|
||||
(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)
|
||||
;; module servlet
|
||||
[(void? s)
|
||||
|
|
@ -359,7 +339,7 @@
|
|||
timeouts-servlet-connection
|
||||
timeout)
|
||||
(v1.module->v1.lambda timeout start)))]
|
||||
[(v2-transitional) ; XXX: Undocumented
|
||||
[(v2 v2-transitional) ; XXX: Undocumented
|
||||
(let ([start (dynamic-require module-name 'start)]
|
||||
[manager (with-handlers
|
||||
([exn:fail:contract?
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -3,13 +3,7 @@
|
|||
(require "private/dispatch-server-sig.ss")
|
||||
(provide ; XXX contract signature
|
||||
(rename dispatch-server^ web-server^)
|
||||
servlet^ 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!))
|
||||
web-config^ web-config/pervasive^ web-config/local^)
|
||||
|
||||
; more here - rename
|
||||
(define-signature web-config/pervasive^
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user