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

14
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"])))))))
(define (start initial-request)
(send/suspend (send/suspend
(lambda (k-url) (lambda (k-url)
`(html (head (title "Sum")) `(html (head (title "Sum"))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p "The sum is " (p "The sum is "
,(number->string (+ (request-number "first") (request-number "second"))))))))) ,(number->string (+ (request-number "first") (request-number "second"))))))))))

18
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)
(let ([count 0] (define timeout +inf.0)
[date (date->string (seconds->date (current-seconds)) 'time-too)])
(unit (import servlet^)
(export)
(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")) `(html (head (title "Counter"))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p "This servlet was called " ,(number->string count) (p "This servlet was called " ,(number->string count)
" times since loaded on " ,date "."))))) " times since loaded on " ,a-date ".")))))

12
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!")
(define (start initial-request)
`(html (head (title ,the-text)) `(html (head (title ,the-text))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p ,the-text)))) (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

14
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"])))))))
(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 (+ (request-number "first") (request-number "second"))))))) ,(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)))

11
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

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

@ -1,12 +1,10 @@
(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 multiply@ (define interface-version 'v1)
(unit (define timeout +inf.0)
(import servlet^ my-servlet-helpers^)
(export)
; matrix = (listof (listof num)) ; matrix = (listof (listof num))
@ -79,6 +77,7 @@
m))) m)))
; main ; main
(define (start initial-request)
`(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 ".")))))

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

13
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)
(unit (import servlet^) (define timeout +inf.0)
(export) (define (start initial-request)
(define the-text "Hello, Web!") (define the-text "Hello, Web!")
`(html (head (title ,the-text)) `(html (head (title ,the-text))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p ,the-text)))) (p ,the-text)))))

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

@ -11,21 +11,20 @@
;; 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 ;; Configuration
(define *data-file* (define *data-file*
(build-path (collection-path "web-server") (build-path (collection-path "web-server")
"default-web-root" "servlets" "examples" "english-measure-questions.ss")) "default-web-root" "servlets" "examples" "english-measure-questions.ss"))
(define *questions-per-quiz* 5) (define *questions-per-quiz* 5)
(require (lib "servlet.ss" "web-server")
(require (lib "unit.ss")
(lib "servlet-sig.ss" "web-server")
(lib "list.ss") (lib "list.ss")
(lib "etc.ss")) (lib "etc.ss"))
(unit (import servlet^) (provide (all-defined))
(export) (define interface-version 'v1)
(define timeout +inf.0)
;; Accessors into question sexp's ;; Accessors into question sexp's
(define question-text car) (define question-text car)
@ -201,8 +200,6 @@
(run-quiz)) (run-quiz))
;; Entry point into servlet. ;; Entry point into servlet.
(run-quiz) (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)))

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

@ -1,10 +1,9 @@
(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)
@ -12,4 +11,4 @@
"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"))))))

13
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)
(define (start initial-request)
`("text/uber-format" `("text/uber-format"
"uber uber uber" "uber uber uber"
"-de-doo")) "-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"])))))))))))

24
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))
(define interface-version 'v1)
(define timeout +inf.0)
(let* ([line-size 80] (define line-size 80)
[build-a-str (define (build-a-str n)
(lambda (n)
(list->string (let loop ([n n]) (list->string (let loop ([n n])
(cond (cond
[(zero? n) (list #\newline)] [(zero? n) (list #\newline)]
[else (cons #\a (loop (sub1 n)))]))))] [else (cons #\a (loop (sub1 n)))]))))
[line (build-a-str (sub1 line-size))] (define line (build-a-str (sub1 line-size)))
[html-overhead 68]) (define html-overhead 68)
(unit (define (start initial-request)
(import servlet^) (define bindings (request-bindings initial-request))
(export)
(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"))

15
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?

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

@ -1,22 +1,22 @@
(module configure mzscheme (module configure mzscheme
(require (lib "unit.ss") (require (lib "servlet.ss" "web-server")
(lib "servlet-sig.ss" "web-server")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "etc.ss") (lib "etc.ss")
(lib "list.ss") (lib "list.ss")
(lib "pretty.ss") (lib "pretty.ss")
(lib "file.ss") (lib "file.ss")
(lib "contract.ss")
(only (lib "configuration.ss" "web-server") (only (lib "configuration.ss" "web-server")
default-configuration-table-path) default-configuration-table-path)
(lib "configuration-table-structs.ss" "web-server" "private") (lib "configuration-table-structs.ss" "web-server" "private")
(lib "parse-table.ss" "web-server" "private") (lib "parse-table.ss" "web-server" "private")
(lib "configuration-util.ss" "web-server" "private") (lib "configuration-util.ss" "web-server" "private")
(lib "util.ss" "web-server" "private")) (lib "util.ss" "web-server" "private"))
(provide/contract (provide
[servlet unit?] interface-version timeout
; XXX contract start)
[servlet-maker (string? . -> . unit?)])
(define timeout (* 12 60 60))
(define interface-version 'v1)
;; FIX ;; FIX
; - fuss with changing absolute paths into relative ones internally ; - fuss with changing absolute paths into relative ones internally
@ -30,18 +30,13 @@
; - change all configuration paths (in the configure servlet and in the server) to ; - change all configuration paths (in the configure servlet and in the server) to
; use a platform independent representation (i.e. a listof strings) ; use a platform independent representation (i.e. a listof strings)
; servlet-maker : str -> (unit/sig servlet^ -> ()) (define default-configuration-path default-configuration-table-path)
(define (servlet-maker default-configuration-path) (define (set-config-path! new)
(unit (set! default-configuration-path new))
(import servlet^)
(export)
(define CONFIGURE-SERVLET-NAME "configure.ss") (define CONFIGURE-SERVLET-NAME "configure.ss")
(define WIDE "70") (define WIDE "70")
(adjust-timeout! (* 12 60 60))
(error-print-width 800) ; 10-ish lines
; passwords = (listof realm) ; passwords = (listof realm)
; realm = (make-realm str str (listof user-pass)) ; realm = (make-realm str str (listof user-pass))
(define-struct realm (name pattern allowed)) (define-struct realm (name pattern allowed))
@ -84,8 +79,6 @@
(send/finish access-error-page)) (send/finish access-error-page))
request) request)
(check-ip-address initial-request)
(define web-base (directory-part default-configuration-path)) (define web-base (directory-part default-configuration-path))
; more here - abstract with static pages? ; more here - abstract with static pages?
@ -182,7 +175,7 @@
; switch-to-current-port : configuration-table -> (U #f configuration-table) ; switch-to-current-port : configuration-table -> (U #f configuration-table)
; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway ; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway
; perhaps the server could include it? ; perhaps the server could include it?
'(define (switch-to-current-port old) #;(define (switch-to-current-port old)
(let ([current-port (url-port (request-uri initial-request))]) (let ([current-port (url-port (request-uri initial-request))])
(and (not (= current-port (configuration-table-port old))) (and (not (= current-port (configuration-table-port old)))
(make-configuration-table (make-configuration-table
@ -636,8 +629,8 @@
; Little Helpers ; Little Helpers
; initialization-error-page : response ; initialization-error-page : request -> response
(define initialization-error-page (define (initialization-error-page initial-request)
`(html (head (title "Web Server Configuration Program Invocation Error")) `(html (head (title "Web Server Configuration Program Invocation Error"))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p "Please direct your browser directly to the " (p "Please direct your browser directly to the "
@ -781,12 +774,12 @@
file-path file-path
(lambda (out) (lambda (out)
(pretty-print (pretty-print
`(require (lib ,CONFIGURE-SERVLET-NAME "web-server")) `(module ,CONFIGURE-SERVLET-NAME mzscheme
(require (lib ,CONFIGURE-SERVLET-NAME "web-server" "private"))
(provide (all-from (lib ,CONFIGURE-SERVLET-NAME "web-server" "private")))
(set-config-path! ,(path->string configuration-path)))
out) out)
(newline out) (newline out))))))
(pretty-print
`(servlet-maker ,(path->string configuration-path))
out))))))
; extract-definition : sym (listof s-expr) -> s-expr ; extract-definition : sym (listof s-expr) -> s-expr
; to return the rhs from (def name rhs) not (def (name . args) body) ; to return the rhs from (def name rhs) not (def (name . args) body)
@ -804,6 +797,7 @@
(define build-path-maybe-expression->file-name caddr) (define build-path-maybe-expression->file-name caddr)
; main ; main
(define (start initial-request)
(error-print-width 800) ; 10-ish lines
(check-ip-address initial-request)
(choose-configuration-file))) (choose-configuration-file)))
(define servlet (servlet-maker default-configuration-table-path)))

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^