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

added 'more: systems' doc

Browse Source 
svn: r8341
This commit is contained in:
Matthew Flatt 2008-01-16 00:21:19 +00:00
parent 4213249665
commit b014545c7a
23 changed files with 1646 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mzlib/control.ss
View File

@ -1,6 +1,8 @@
(module control mzscheme
(provide fcontrol %
(provide abort
fcontrol %
control prompt control-at prompt-at
;; `-at' variations expect a prompt tag
@ -16,6 +18,13 @@
new-prompt set cupto)
;; ----------------------------------------
(define (abort . vals)
(abort-current-continuation
(default-continuation-prompt-tag)
(lambda () (apply values vals))))
;; ----------------------------------------
;; Sitaram, PLDI'93
;; The `%' here is compable with Sitaram & Felleisen, LSC'90,

4
collects/readline/main.ss Normal file
View File

@ -0,0 +1,4 @@
#lang scheme
(require "rep.ss")
(provide (all-from-out "rep.ss"))

25
collects/readline/readline.scrbl
View File

@ -17,15 +17,15 @@ library with the MzScheme @scheme[read-eval-print-loop].
@section{Normal Use of @|Readline|}
@defmodule*[(readline/rep readline/rep-start)]
@defmodule*[(readline readline/rep-start)]
The @schememodname[readline/rep] library installs a @|readline|-based
The @schememodname[readline] library installs a @|readline|-based
input port, and hooks the prompt-and-read part of MzScheme's
@scheme[read-eval-print-loop] to interact with it
You can start MzScheme with
@commandline{mzscheme -il readline/rep}
@commandline{mzscheme -il readline}
or you can put the following in your @filepath{~/.mzschemerc} so that
MzScheme starts with @|readline| support when appropriate:
@ -33,16 +33,15 @@ MzScheme starts with @|readline| support when appropriate:
@schemeblock[
(when (regexp-match? #rx"xterm"
(getenv "TERM"))
(dynamic-require 'readline/rep #f))
(dynamic-require 'readline #f))
]
The @schememodname[readline/rep] module is actually a wrapper around
The @schememodname[readline] module is mostly a wrapper around
@schememodname[readline/rep-start]; it will @emph{not} invoke
@schememodname[readline/rep-start] if the input port is not a terminal
port (e.g., when the input is redirected from a file); see
@scheme[terminal-port?]. Still, the @envvar{TERM} condition
above is useful for starting MzScheme in dumb terminals (e.g., inside
Emacs.)
@schememodname[readline/rep--start] if the input port is not a
terminal port (e.g., when the input is redirected from a file); see
@scheme[terminal-port?]. Still, the @envvar{TERM} condition above is
useful for starting MzScheme in dumb terminals (e.g., inside Emacs).
Completion is set to use the visible bindings in the current
namespace; this is far from ideal, but it's better than @|readline|'s
@ -55,7 +54,7 @@ preferences file, assuming that MzScheme exits normally.
@defmodule[readline/pread]{ The @schememodname[readline/pread] library
provides customization, and support for prompt-reading after
@schememodname[readline/rep] installs the new input port.}
@schememodname[readline] installs the new input port.}
The reading facility that the new input port provides can be
customized with the following parameters.
@ -106,7 +105,7 @@ kept in history.}
@defparam[readline-prompt status (or/c false/c bytes? (one-of/c 'space))]{
The new input port that you get when you require
@schememodname[readline/rep] is a custom port that uses @|readline| for
@schememodname[readline] is a custom port that uses @|readline| for
all inputs. The problem is when you want to display a prompt and then
read some input, @|readline| will get confused if it is not used when the
cursor is at the beginning of the line (which is why it has a
@ -128,7 +127,7 @@ A proper solution would be to install a custom output port, too, which
keeps track of text that is displayed without a trailing newline. As
a cheaper solution, if line-counting is enabled for the terminal's
output-port, then a newline is printed before reading if the column is
not 0. (The @schememodname[readline/rep] library enables line-counting
not 0. (The @schememodname[readline] library enables line-counting
for the output port.)
@bold{Warning:} The @|readline| library uses the output port directly.

50
collects/readline/rep.ss
View File

@ -1,10 +1,44 @@
;; This is a wrapper around "rep-start.ss" -- use it if we're using a terminal
(module rep mzscheme
(require (lib "runtime-path.ss"))
(define-runtime-path rep-start "rep-start.ss")
#lang scheme/base
(let ([inp (current-input-port)] [outp (current-output-port)])
(when (and (eq? 'stdin (object-name inp)) (terminal-port? inp))
(dynamic-require rep-start #f)
(when (terminal-port? outp)
(port-count-lines! outp)))))
(require scheme/runtime-path
(for-syntax scheme/base))
(define-runtime-path rep-start "rep-start.ss")
(provide install-readline!)
(let ([inp (current-input-port)] [outp (current-output-port)])
(when (and (eq? 'stdin (object-name inp)) (terminal-port? inp))
(dynamic-require rep-start #f)
(when (terminal-port? outp)
(port-count-lines! outp))))
(define readline-init-expr
'(require readline/rep))
(define (install-readline!)
(let ([file (find-system-path 'init-file)])
(when (or (not (file-exists? file))
(not (with-handlers ([exn:fail?
(lambda (exn)
(error 'install-readline!
"trouble reading existing ~e: ~a"
file
(exn-message exn)))])
(call-with-input-file*
file
(lambda (in)
(let loop ()
(let ([v (read in)])
(cond
[(eof-object? v) #f]
[(equal? v readline-init-expr) #t]
[else (loop)]))))))))
(call-with-output-file*
file
#:exists 'append
(lambda (out)
(newline out)
(write readline-init-expr out)
(newline out))))))

71
collects/scheme/enter.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require syntax/modcode
(for-syntax scheme/base))
(provide enter!)
@ -25,8 +26,74 @@
(define (do-enter! mod)
(if mod
(begin
(dynamic-require mod #f)
(enter-require mod)
(let ([ns (module->namespace mod)])
(current-namespace ns)
(namespace-require 'scheme/enter)))
(current-namespace orig-namespace)))
(define-struct mod (name timestamp depends))
(define loaded (make-hash-table 'equal))
(define (enter-require mod)
;; Collect dependencies while loading:
(parameterize ([current-load/use-compiled
(enter-load/use-compiled (current-load/use-compiled) #f)])
(dynamic-require mod #f))
;; Reload anything that's not up to date:
(check-latest mod))
(define ((enter-load/use-compiled orig re?) path name)
(printf " [~aloading ~a]\n" (if re? "re-" "") path)
(if name
;; Module load:
(let ([code (get-module-code path
"compiled"
(lambda (e)
(parameterize ([compile-enforce-module-constants #f])
(compile e)))
(lambda (ext loader?)
(load-extension ext)
#f))]
[path (normal-case-path
(simplify-path
(path->complete-path path
(or (current-load-relative-directory)
(current-directory)))))])
;; Record module timestamp and dependencies:
(let ([mod (make-mod name
(get-timestamp path)
(call-with-values
(lambda () (module-compiled-imports code))
append))])
(hash-table-put! loaded path mod))
;; Evaluate the module:
(eval code))
;; Not a module:
(orig path name)))
(define (get-timestamp path)
(file-or-directory-modify-seconds path #f (lambda () -inf.0)))
(define (check-latest mod)
(let ([mpi (module-path-index-join mod #f)]
[done (make-hash-table 'equal)])
(let loop ([mpi mpi])
(let* ([rpath (module-path-index-resolve mpi)]
[path (resolved-module-path-name rpath)])
(when (path? path)
(unless (hash-table-get done path #f)
(hash-table-put! done path #t)
(let ([mod (hash-table-get loaded path #f)])
(when mod
(for-each loop (mod-depends mod))
(let ([ts (get-timestamp path)])
(when (ts . > . (mod-timestamp mod))
(let ([orig (current-load/use-compiled)])
(parameterize ([current-load/use-compiled
(enter-load/use-compiled orig #f)]
[current-module-declare-name rpath])
((enter-load/use-compiled orig #t)
path
(mod-name mod))))))))))))))

4
collects/scribblings/more/info.ss Normal file
View File

@ -0,0 +1,4 @@
(module info setup/infotab
(define name "Scribblings: More")
(define scribblings '(("more.scrbl" ())))
(define doc-categories '((getting-started 1))))

810
collects/scribblings/more/more.scrbl Normal file
View File

@ -0,0 +1,810 @@
#lang scribble/doc
@(require scribble/manual
scribble/urls
scribble/eval
"../quick/keep.ss"
(for-label scheme
readline
net/url
xml
scheme/control))
@(define quick @other-manual['(lib "quick.scrbl" "scribblings/quick")])
@(define guide @other-manual['(lib "guide.scrbl" "scribblings/guide")])
@(define break-eval (make-base-eval))
@interaction-eval[#:eval break-eval
(define (show-reload)
(printf " [re-loading serve.ss]\n"))]
@interaction-eval[#:eval break-eval
(define (serve n) void)]
@interaction-eval[#:eval break-eval
(define (show-break)
(fprintf (current-error-port) "^Cuser break"))]
@interaction-eval[#:eval break-eval
(define (show-fail n)
(error 'tcp-listen
"listen on ~a failed (Address already in use; errno=48)"
n))]
@interaction-eval[#:eval break-eval (require xml net/url)]
@(define (whole-prog which [last? #f])
(let ([file (format "step~a.txt" which)])
(margin-note (keep-file file)
"Here's the "
(if last?
"final program"
"whole program so far")
" in plain text: "
(link file "step " which) ".")))
@title{@bold{More}: Systems Programming with PLT Scheme (in Plain Text)}
In contrast to the impression that @|quick| may give, PLT Scheme is
not just another pretty face. Underneath the graphical facade of
DrScheme lies a sophisticated toolbox for managing threads and
processes, which is the subject of this tutorial.
Specifically, we show how to build a secure, multi-threaded,
servlet-extensible, continuation-based web server. We use much more of
the language than in @|quick|, and beware that the last couple of
sections present material that is normally considered difficult. So if
you're still new to Scheme, you may want to skip to @|guide|.
To get into the spirit of this tutorial, we suggest that you set
DrScheme aside for a moment, and switch to raw @exec{mzscheme} in a
terminal. You'll also need a text editor, such as @exec{emacs} or
@exec{vi}. Finally, you'll need a web client, perhaps @exec{lynx} or
@exec{firefox}.
@margin-note{Of course, if you're already spoiled, you can keep using
DrScheme.}
@; ----------------------------------------------------------------------
@section{Ready...}
@link[url:download-drscheme]{Download PLT Scheme}, install, and then
start @exec{mzscheme} with no command-line arguments:
@verbatim[#<<EOS
$ mzscheme
Welcome to MzScheme
>
EOS
]
If you're using a plain Unix terminal (e.g., not inside @exec{emacs}),
if you have GNU Readline installed on your system, and if you'd like
Readline support in @exec{mzscheme}, then evaluate
@scheme[(require readline)]. If you also evaluate
@scheme[(install-readline!)], then your @filepath{~/.mzschemerc} is
updated to load Readline whenever you start @exec{mzscheme} for
interactive evaluation.
@margin-note{Unfortunately, for legal reasons related to GPL vs. LGPL,
@exec{mzscheme} cannot provide Readline automatically.}
@interaction[
(eval:alts (require readline) (void))
(eval:alts (install-readline!) (void))
]
@; ----------------------------------------------------------------------
@section{Set...}
In the same directory where you started @exec{mzscheme}, create a text
file @filepath{serve.ss}, and start it like this:
@schememod[
scheme
(define (go)
'yep-it-works)
]
@whole-prog["0"]
@; ----------------------------------------------------------------------
@section{Go!}
Back in @exec{mzscheme}, try loading the file and running @scheme[go]:
@interaction[
(eval:alts (enter! "serve.ss") (printf " [loading serve.ss]\n"))
(eval:alts (go) 'yep-it-works)
]
Try modifying @filepath{serve.ss}, and then running @scheme[(enter!
"serve.ss")] again to re-load the module, then check your changes.
@; ----------------------------------------------------------------------
@section{``Hello World'' Server}
We'll implement the web server through a @scheme[serve] function that
takes a IP port number for client connections:
@schemeblock[
(define (serve port-no)
...)
]
The server accepts TCP connections through a @defterm{listener}, which
we create with @scheme[tcp-listen]. To make interactive development
easier, we supply @scheme[#t] as the third argument to
@scheme[tcp-listen], which lets us re-use the port number without
waiting on TCP timeouts.
@schemeblock[
(define (serve port-no)
(define listener (tcp-listen port-no 5 #t))
...)
]
The server must loop to accept connections from the listener:
@schemeblock[
(define (serve port-no)
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(loop))
]
Our @scheme[accept-and-handle] function accepts a connection using
@scheme[tcp-accept], which returns two values: a stream for input from
the client, and a stream for output to the client.
@schemeblock[
(define (accept-and-handle listener)
(define-values (in out) (tcp-accept listener))
(handle in out)
(close-input-port in)
(close-output-port out))
]
To handle a connection, for now, we'll read and discard the request
header, and then write a ``Hello, world!'' web page as the result:
@schemeblock[
(define (handle in out)
(code:comment #, @t{Discard the request header (up to blank line):})
(regexp-match #rx#"(\r\n|^)\r\n" in)
(code:comment #, @t{Send reply:})
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display "<html><body>Hello, world!</body></html>" out))
]
Note that @scheme[regexp-match] operates directly on the input stream,
which is easier than bothering with individual lines.
@whole-prog["1"]
Copy the above three definitions---@scheme[serve],
@scheme[accept-and-handle], and @scheme[handle]---into
@filepath{serve.ss} and re-load:
@interaction[
#:eval break-eval
(eval:alts (enter! "serve.ss") (show-reload))
(eval:alts (serve 8080) (void))
]
Now point your browser to @tt{http://localhost:8080} (assuming that
you used @scheme[8080] as the port number, and that the browser is
running on the same machine) to receive a friendly greeting from your
web server.
@; ----------------------------------------------------------------------
@section{Server Thread}
Before we can make the web server respond in more interesting ways, we
need to get a Scheme prompt back. Typing Ctl-C in your terminal window
interrupts the server loop:
@margin-note{In DrScheme, instead of typing Ctl-C, click the
@onscreen{Stop} button once.}
@interaction[
#:eval break-eval
(eval:alts (serve 8080) (show-break))
(eval:alts code:blank (void))
]
Unfortunately, we cannot now re-start the server with the same port
number:
@interaction[
#:eval break-eval
(eval:alts (serve 8080) (show-fail 8080))
]
The problem is that the listener that we created with @scheme[serve]
is still listening on the original port number.
To avoid this problem, let's put the listener loop in its own thread,
and have @scheme[serve] return immediately. Furthermore, we'll have
@scheme[serve] return a function that can be used to shut down the
server thread and TCP listener:
@schemeblock[
(define (serve port-no)
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(define t (thread loop))
(lambda ()
(kill-thread t)
(tcp-close listener)))
]
@whole-prog["2"]
Try the new one:
@interaction[
#:eval break-eval
(eval:alts (enter! "serve.ss") (show-reload))
(define stop (serve 8081))
]
Your server should now respond to @tt{http://localhost:8081}, but you
can shut down and restart the server on the same port number as often
as you like:
@interaction[
#:eval break-eval
(stop)
(define stop (serve 8081))
(stop)
(define stop (serve 8081))
(stop)
]
@; ----------------------------------------------------------------------
@section{Connection Threads}
In the same way that we put the main server loop into a background
thread, we can put each individual connection into its own thread:
@schemeblock[
(define (accept-and-handle listener)
(define-values (in out) (tcp-accept listener))
(thread
(lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
]
@whole-prog["3"]
With this change, our server can now handle multiple threads at
once. The handler is so fast that this fact will be difficult to
detect, however, so try inserting @scheme[(sleep (random 10))] before
the @scheme[handle] call above. If you make multiple connects from the
web browser at the same time, some will return right away, and some
will take up to 10 seconds. The random delays will be independent of
the order in which you started the connections.
@; ----------------------------------------------------------------------
@section{Terminating Connections}
A malicious client could connect to our web server and not send the
HTTP header, in which case a connection thread will idle forever,
waiting for the end of the header. To avoid this possibility, we'd
like to implement a timeout for each connection thread.
One way to implement the timeout is to create a second thread that
waits for 10 seconds, and then kills the thread that calls
@scheme[handle]. Threads are lightweight enough that this
watcher-thread strategy works well:
@schemeblock[
(define (accept-and-handle listener)
(define-values (in out) (tcp-accept listener))
(define t (thread
(lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
(code:comment #, @t{Watcher thread:})
(thread (lambda ()
(sleep 10)
(kill-thread t))))
]
This first attempt isn't quite right, because when the thread is
killed, its @scheme[in] and @scheme[out] streams remain open. We
could add code to the watcher thread to close the streams as well as
kill the thread, but Scheme offers a more general shutdown mechanism:
@defterm{custodians}. A custodian is a kind of container for all
resources other than memory, and it supports a
@scheme[custodian-shutdown-all] that terminates and closes all
resources within the container, whether they're threads, streams, or
other kinds of limited resources.
Whenever a thread or stream is created, it is placed into the current
custodian as determined by the @scheme[current-custodian]
parameter. To place everything about a connection into a custodian, we
@scheme[parameterize] all the resources creations to go into a new
one:
@schemeblock[
(define (accept-and-handle listener)
(define cust (make-custodian))
(parameterize ([current-custodian cust])
(define-values (in out) (tcp-accept listener))
(thread (lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
(code:comment #, @t{Watcher thread:})
(thread (lambda ()
(sleep 10)
(custodian-shutdown-all cust))))
]
With this implementation, @scheme[in], @scheme[out], and the thread
that calls @scheme[handle] all belong to the @scheme[cust]
custodian. In addition, if we later change @scheme[handle] so that it,
say, opens a file, then the file handles will also belong to
@scheme[cust], so they will be reliably closed when @scheme[cust] is
shut down.
In fact, it's a good idea to change @scheme[serve] to that it uses a
custodian, too:
@schemeblock[
(define (serve port-no)
(define main-cust (make-custodian))
(parameterize ([current-custodian main-cust])
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(thread loop))
(lambda ()
(custodian-shutdown-all main-cust)))
]
That way, the @scheme[main-cust] created in @scheme[serve] not only
owns the TCP listener and the main server thread, it also owns every
custodian created for a connection. Consequently, the revised shutdown
procedure for the server immediately terminates any active connection,
in addition to the main server loop.
@whole-prog["4"]
After updating the @scheme[serve] and @scheme[accept-and-handle]
functions as above, here's how you can simulate a malicious client:
@interaction[
#:eval break-eval
(eval:alts (enter! "serve.ss") (show-reload))
(define stop (serve 8081))
(eval:alts (define-values (cin cout) (tcp-connect "localhost" 8081)) (void))
]
Now wait 10 seconds. If you try reading from @scheme[cin], which is
the stream that sends data from the server back to the client, you'll
find that the server has shut down the connection:
@interaction[
#:eval break-eval
(eval:alts (read-line cin) eof)
]
Alternatively, you don't have to wait 10 seconds if you explicitly
shut down the server:
@interaction[
#:eval break-eval
(eval:alts (define-values (cin2 cout2) (tcp-connect "localhost" 8081)) (void))
(stop)
(eval:alts (read-line cin2) eof)
]
@; ----------------------------------------------------------------------
@section{Dispatching}
It's finally time to generalize our server's ``Hello, World!''
response to something more useful. Let's adjust the server so that we
can plug in dispatching functions to handle requests to different
URLs.
To parse the incoming URL and to more easily format HTML output, we'll
require two extra libraries:
@schemeblock[
(require net/url xml)
]
The @schememodname[xml] library gives us @scheme[xexpr->string], which
takes a Scheme value that looks like HTML and turns it into actual
HTML:
@interaction[
#:eval break-eval
(xexpr->string '(html (head (title "Hello")) (body "Hi!")))
]
We'll assume that our new @scheme[dispatch] function (to be written)
takes a requested URL and produces a result value suitable to use with
@scheme[xexpr->string] to send back to the client:
@schemeblock[
(define (handle in out)
(define req
(code:comment #, @t{Match the first line to extract the request:})
(regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+"
(read-line in)))
(when req
(code:comment #, @t{Discard the rest of the header (up to blank line):})
(regexp-match #rx#"(\r\n|^)\r\n" in)
(code:comment #, @t{Dispatch:})
(let ([xexpr (dispatch (list-ref req 1))])
(code:comment #, @t{Send reply:})
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display (xexpr->string xexpr) out))))
]
The @schememodname[net/url] library gives us @scheme[string->url],
@scheme[url-path], @scheme[path/param-path], and @scheme[url-query]
for getting from a string to parts of the URL that it represents:
@interaction[
#:eval break-eval
(define u (string->url "http://localhost:8080/foo/bar?x=bye"))
(url-path u)
(map path/param-path (url-path u))
(url-query u)
]
We use these pieces to implement @scheme[dispatch]. The
@scheme[dispatch] function consults a hash table that maps an initial
path element, like @scheme["foo"], to a handler function:
@schemeblock[
(define (dispatch str-path)
(code:comment #, @t{Parse the request as a URL:})
(define url (string->url str-path))
(code:comment #, @t{Extract the path part:})
(define path (map path/param-path (url-path url)))
(code:comment #, @t{Find a handler based on the path's first element:})
(define h (hash-table-get dispatch-table (car path) #f))
(if h
(code:comment #, @t{Call a handler:})
(h (url-query url))
(code:comment #, @t{No handler found:})
`(html (head (title "Error"))
(body
(font ((color "red"))
"Unknown page: "
,str-path)))))
(define dispatch-table (make-hash-table 'equal))
]
With the new @scheme[require] import and new @scheme[handle],
@scheme[dispatch], and @scheme[dispatch-table] definitions, our
``Hello World!'' server has turn into an error server. You don't have
to stop the server to try it out. After modifying @filepath{serve.ss}
with the new pieces, evaluate @scheme[(enter! "serve.ss")] and then
try again to connect to the server. The web browser should show an
``Unknown page'' error in red.
We can register a handler for the @scheme["hello"] path like this:
@schemeblock[
(hash-table-put! dispatch-table "hello"
(lambda (query)
`(html (body "Hello, World!"))))
]
@whole-prog["5"]
After adding these lines and evaluating @scheme[(enter! "serve.ss")],
opening @tt{http://localhost:8081/hello} should produce the old
greeting.
@; ----------------------------------------------------------------------
@section{Servlets and Sessions}
Using the @scheme[query] argument that is passed to a handler by
@scheme[dispatch], a handler can respond to values that a user
supplies through a form.
The following helper function constructs an HTML form. The
@scheme[label] argument is a string to show the user. The
@scheme[next-url] argument is destination for the form results. The
@scheme[hidden] argument is a value to propagate through the form as a
hidden field. When the user responds, the @scheme["number"] field in
the form holds the user's value:
@schemeblock[
(define (build-request-page label next-url hidden)
`(html
(head (title "Enter a Number to Add"))
(body ([bgcolor "white"])
(form ([action ,next-url] [method "get"])
,label
(input ([type "text"] [name "number"]
[value ""]))
(input ([type "hidden"] [name "hidden"]
[value ,hidden]))
(input ([type "submit"] [name "enter"]
[value "Enter"]))))))
]
Using this helper function, we can create a servlet that generates as
many ``hello''s as a user wants:
@schemeblock[
(define (many query)
(build-request-page "Number of greetings:" "/reply" ""))
(define (reply query)
(define n (string->number (cdr (assq 'number query))))
`(html (body ,@(for ([i (in-range n)])
" hello"))))
(hash-table-put! dispatch-table "many" many)
(hash-table-put! dispatch-table "reply" reply)
]
@whole-prog["6"]
As usual, once you have added these to your program, update with
@scheme[(enter! "serve.ss")], and then visit
@tt{http://localhost:8081/many}. Provide a number, and then you'll get
a new page with that many ``hello''s.
@; ----------------------------------------------------------------------
@section{Limiting Memory Use}
With our latest @scheme["many"] servlet, we seem to have a new
problem: a malicious client could request so many ``hello''s that the
server runs out of memory. Actually, a malicious client could also
supply an HTTP request whose first line is arbitrarily long.
The solution to this class of problems is to limit the memory use of a
connection. Inside @scheme[accept-and-handle], after the definition of
@scheme[cust], add the line
@scheme[(custodian-limit-memory cust (* 50 1024 1024))]
@whole-prog["7"]
We're assuming that 50MB should be plenty for any servlet. Due to the
way that memory accounting is defined, @scheme[cust] might also be
charged for the core server implementation and all of the libraries
loaded on start-up, so the limit cannot be too small. Also,
garbage-collector overhead means that the actual memory use of the
system can be some small multiple of 50 MB. The main guarantee is that
different connections will not be charged for each other's memory use.
So, with the new line above, and assuming that you have a couple of
hundred megabytes available for the @exec{mzscheme} process to use,
then with the above limit, you shouldn't be able to crash the web
server by requesting a ridiculously large number of ``hello''s.
Given the @scheme["many"] example, it's a small step to a web server
that accepts from clients arbitrary code to execute on the server. In
that case, there are many additional security issues besides limiting
processor time and memory consumption. The
@schememodname[scheme/sandbox] library provides support to managing
all those other issues.
@; ----------------------------------------------------------------------
@section{Continuations}
As a systems example, the problem of implementing a web server exposes
many system and security issues where a programming language can
help. The web-server example also leads to a classic, advanced Scheme
topic: @defterm{continuations}. In fact, this facet of a web server
needs @defterm{delimited continuations}, which PLT Scheme provides.
The problem solved by continuations is related to servlet sessions and
user input, where a computation spans multiple client
connections. Often, client-side computation (as in AJAX) is the right
solution to the problem, but many problems are best solved with a
mixture of techniques (e.g., to take advantage of the browser's
``back'' button).
As the multi-connection computation becomes more complex, propagating
arguments through @scheme[query] becomes increasingly tedious. For
example, we can implement a servlet that takes two numbers to add by
using the hidden field in the form to remember the first number:
@schemeblock[
(define (sum query)
(build-request-page "First number:" "/one" ""))
(define (one query)
(build-request-page "Second number:"
"/two"
(cdr (assq 'number query))))
(define (two query)
(let ([n (string->number (cdr (assq 'hidden query)))]
[m (string->number (cdr (assq 'number query)))])
`(html (body "The sum is " ,(number->string (+ m n))))))
(hash-table-put! dispatch-table "sum" sum)
(hash-table-put! dispatch-table "one" one)
(hash-table-put! dispatch-table "two" two)
]
@whole-prog["8"]
While the above works, we would much rather write such computations in
a direct style:
@schemeblock[
(define (sum2 query)
(define m (get-number "First number:"))
(define n (get-number "Second number:"))
`(html (body "The sum is " ,(number->string (+ m n)))))
(hash-table-put! dispatch-table "sum2" sum2)
]
The problem is that @scheme[get-number] needs to send an HTML response
back for the current connection, and then it must obtain a response
through a new connection. That is, somehow it needs to convert the
page generated by @scheme[build-request-page] into a @scheme[query]
result:
@schemeblock[
(define (get-number label)
(define query
... (build-request-page label ...) ...)
(number->string (cdr (assq 'number query))))
]
Continuations let us implement a @scheme[send/suspend] operation that
performs exactly that operation. The @scheme[send/suspend] procedure
generates a URL that represents the current connection's computation,
capturing it as a continuation. It passes the generated URL to a
procedure that creates the query page; this query page is used as the
result of the current connection, and the surrounding computation
(i.e., the continuation) is aborted. Finally, @scheme[send/suspend]
arranges for a request to the generated URL (in a new connection) to
restore the aborted computation.
Thus, @scheme[get-number] is implemented as follows:
@schemeblock[
(define (get-number label)
(define query
(code:comment #, @t{Generate a URL for the current computation:})
(send/suspend
(code:comment #, @t{Receive the computation-as-URL here:})
(lambda (k-url)
(code:comment #, @t{Generate the query-page result for this connection.})
(code:comment #, @t{Send the query result to the saved-computation URL:})
(build-request-page label k-url ""))))
(code:comment #, @t{We arrive here later, in a new connection})
(string->number (cdr (assq 'number query))))
]
We still have to implement @scheme[send/suspend]. Plain Scheme's
@scheme[call/cc] is not quite enough, so we import a library of
control operators:
@schemeblock[(require scheme/control)]
Specifically, we need @scheme[prompt] and @scheme[abort] from
@schememodname[scheme/control]. We use @scheme[prompt] to mark the
place where a servlet is started, so that we can abort a computation
to that point. Change @scheme[handle] by wrapping an @scheme[prompt]
around the cal to @scheme[dispatch]:
@schemeblock[
(define (handle in out)
....
(let ([xexpr (prompt (dispatch (list-ref req 1)))])
....))
]
Now, we can implement @scheme[send/suspend]. We use @scheme[call/cc]
in the guise of @scheme[let/cc], which captures the current
computation up to an enclosing @scheme[prompt], and binds that
computation to an identifier---@scheme[k], in this case:
@schemeblock[
(define (send/suspend mk-page)
(let/cc k
...))
]
Next, we generate a new dispatch tag, and we record the mapping from
the tag to @scheme[k]:
@schemeblock[
(define (send/suspend mk-page)
(let/cc k
(define tag (format "k~a" (current-inexact-milliseconds)))
(hash-table-put! dispatch-table tag k)
...))
]
Finally, we abort the current computation, supplying instead the page
that is built by applying the given @scheme[mk-page] to a URL for the
generated tag:
@schemeblock[
(define (send/suspend mk-page)
(let/cc k
(define tag (format "k~a" (current-inexact-milliseconds)))
(hash-table-put! dispatch-table tag k)
(abort (mk-page (string-append "/" tag)))))
]
When the user submits the form, the handler associated with the form's
URL is the old computation, stored as a continuation in the dispatch
table. Invoking the continuation as a function restores the old
computation, passing the @scheme[query] arguments as back to that
computation.
@whole-prog["9" #t]
In summary, the new pieces are: @scheme[(require scheme/control)],
adding @scheme[prompt] inside @scheme[handle], the definitions of
@scheme[send/suspend], @scheme[get-number], and @scheme[sum], and
@scheme[(hash-table-put! dispatch-table "sum2" sum2)]. Once you have
the server updated, visit @tt{http://localhost:8081/sum2}.
@; ----------------------------------------------------------------------
@section{Where to Go From Here}
If the topics covered here are the kind that interest you, see also
@secref["concurrency" #:doc '(lib
"scribblings/reference/reference.scrbl")] and @secref["security" #:doc
'(lib "scribblings/reference/reference.scrbl")] in @other-manual['(lib
"scribblings/reference/reference.scrbl")].
Some of this material is based on relatively recent research, and more
information can be found in papers written by the authors of PLT
Scheme, including papers on MrEd @cite["Flatt99"], memory accounting
@cite["Wick04"], kill-safe abstractions @cite["Flatt04"], and
delimited continuations @cite["Flatt07"].
@; ----------------------------------------------------------------------
@(bibliography
(bib-entry #:key "Flatt99"
#:author "Matthew Flatt, Robert Bruce Findler, Shriram Krishnamurthi, and Matthias Felleisen"
#:title @elem{Programming Languages as Operating Systems
(@emph{or} Revenge of the Son of the Lisp Machine)}
#:location "International Conference on Functional Programming"
#:date "1999"
#:url "http://www.ccs.neu.edu/scheme/pubs/icfp99-ffkf.pdf")
(bib-entry #:key "Flatt04"
#:author "Matthew Flatt and Robert Bruce Findler"
#:title "Kill-Safe Synchronization Abstractions"
#:location "Programming Language Design and Implementation"
#:date "2004"
#:url "http://www.cs.utah.edu/plt/publications/pldi04-ff.pdf")
(bib-entry #:key "Flatt07"
#:author "Matthew Flatt, Gang Yu, Robert Bruce Findler, and Matthias Felleisen"
#:title "Adding Delimited and Composable Control to a Production Programming Environment"
#:location "International Conference on Functional Programming"
#:date "2007"
#:url "http://www.cs.utah.edu/plt/publications/icfp07-fyff.pdf")
(bib-entry #:key "Wick04"
#:author "Adam Wick and Matthew Flatt"
#:title "Memory Accounting without Partitions"
#:location "International Symposium on Memory Management"
#:date "2004"
#:url "http://www.cs.utah.edu/plt/publications/ismm04-wf.pdf")
)

4
collects/scribblings/more/step0.txt Normal file
View File

@ -0,0 +1,4 @@
#lang scheme
(define (go)
'yep-it-works)

22
collects/scribblings/more/step1.txt Normal file
View File

@ -0,0 +1,22 @@
#lang scheme
(define (serve port-no)
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(loop))
(define (accept-and-handle listener)
(define-values (in out) (tcp-accept listener))
(handle in out)
(close-input-port in)
(close-output-port out))
(define (handle in out)
;; Discard the request header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display "<html><body>Hello, world!</body></html>" out))

31
collects/scribblings/more/step2.txt Normal file
View File

@ -0,0 +1,31 @@
#lang scheme
;; The `serve' function is revised to run the loop
;; in a thread, and it returns a function to shut down
;; down the server.
(define (serve port-no)
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(define t (thread loop))
(lambda ()
(kill-thread t)
(tcp-close listener)))
;; The rest is the same as before.
(define (accept-and-handle listener)
(define-values (in out) (tcp-accept listener))
(handle in out)
(close-input-port in)
(close-output-port out))
(define (handle in out)
;; Discard the request header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display "<html><body>Hello, world!</body></html>" out))

31
collects/scribblings/more/step3.txt Normal file
View File

@ -0,0 +1,31 @@
#lang scheme
;; Only `accept-and-handle' changes, moving the
;; handle work into a thread.
(define (serve port-no)
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(define t (thread loop))
(lambda ()
(kill-thread t)
(tcp-close listener)))
(define (accept-and-handle listener)
(define-values (in out) (tcp-accept listener))
(thread
(lambda ()
;; (sleep (random 10)) ; try uncommenting this
(handle in out)
(close-input-port in)
(close-output-port out))))
(define (handle in out)
;; Discard the request header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display "<html><body>Hello, world!</body></html>" out))

36
collects/scribblings/more/step4.txt Normal file
View File

@ -0,0 +1,36 @@
#lang scheme
;; Both `server' and `accept-and-handle' change
;; to use a custodian.
(define (serve port-no)
(define main-cust (make-custodian))
(parameterize ([current-custodian main-cust])
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(thread loop))
(lambda ()
(custodian-shutdown-all main-cust)))
(define (accept-and-handle listener)
(define cust (make-custodian))
(parameterize ([current-custodian cust])
(define-values (in out) (tcp-accept listener))
(thread (lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
;; Watcher thread:
(thread (lambda ()
(sleep 10)
(custodian-shutdown-all cust))))
(define (handle in out)
;; Discard the request header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display "<html><body>Hello, world!</body></html>" out))

76
collects/scribblings/more/step5.txt Normal file
View File

@ -0,0 +1,76 @@
#lang scheme
;; New imports:
(require xml net/url)
;; No changes to `serve' or `accept-and-handle'...
(define (serve port-no)
(define main-cust (make-custodian))
(parameterize ([current-custodian main-cust])
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(thread loop))
(lambda ()
(custodian-shutdown-all main-cust)))
(define (accept-and-handle listener)
(define cust (make-custodian))
(parameterize ([current-custodian cust])
(define-values (in out) (tcp-accept listener))
(thread (lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
;; Watcher thread:
(thread (lambda ()
(sleep 10)
(custodian-shutdown-all cust))))
;; The `handle' function now parses the request into `req', and it
;; calls the new `dispatch' function to get the response, which is an
;; xexpr instead of a string.
(define (handle in out)
(define req
;; Match the first line to extract the request:
(regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+"
(read-line in)))
(when req
;; Discard the rest of the header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Dispatch:
(let ([xexpr (dispatch (list-ref req 1))])
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display (xexpr->string xexpr) out))))
;; New: the `dispatch' function and `dispatch-table':
(define (dispatch str-path)
;; Parse the request as a URL:
(define url (string->url str-path))
;; Extract the path part:
(define path (map path/param-path (url-path url)))
;; Find a handler based on the path's first element:
(define h (hash-table-get dispatch-table (car path) #f))
(if h
;; Call a handler:
(h (url-query url))
;; No handler found:
`(html (head (title "Error"))
(body
(font ((color "red"))
"Unknown page: "
,str-path)))))
(define dispatch-table (make-hash-table 'equal))
;; A simple dispatcher:
(hash-table-put! dispatch-table "hello"
(lambda (query)
`(html (body "Hello, World!"))))

100
collects/scribblings/more/step6.txt Normal file
View File

@ -0,0 +1,100 @@
#lang scheme
;; For changes, skip down to `build-request-page',
;; after the line.
(require xml net/url)
(define (serve port-no)
(define main-cust (make-custodian))
(parameterize ([current-custodian main-cust])
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(thread loop))
(lambda ()
(custodian-shutdown-all main-cust)))
(define (accept-and-handle listener)
(define cust (make-custodian))
(parameterize ([current-custodian cust])
(define-values (in out) (tcp-accept listener))
(thread (lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
;; Watcher thread:
(thread (lambda ()
(sleep 10)
(custodian-shutdown-all cust))))
(define (handle in out)
(define req
;; Match the first line to extract the request:
(regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+"
(read-line in)))
(when req
;; Discard the rest of the header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Dispatch:
(let ([xexpr (dispatch (list-ref req 1))])
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display (xexpr->string xexpr) out))))
(define (dispatch str-path)
;; Parse the request as a URL:
(define url (string->url str-path))
;; Extract the path part:
(define path (map path/param-path (url-path url)))
;; Find a handler based on the path's first element:
(define h (hash-table-get dispatch-table (car path) #f))
(if h
;; Call a handler:
(h (url-query url))
;; No handler found:
`(html (head (title "Error"))
(body
(font ((color "red"))
"Unknown page: "
,str-path)))))
(define dispatch-table (make-hash-table 'equal))
(hash-table-put! dispatch-table "hello"
(lambda (query)
`(html (body "Hello, World!"))))
;; ----------------------------------------
;; New helper function: builds and HTML page
;; for a form that has a "number" field and
;; a "hidden" field:
(define (build-request-page label next-url hidden)
`(html
(head (title "Enter a Number to Add"))
(body ([bgcolor "white"])
(form ([action ,next-url] [method "get"])
,label
(input ([type "text"] [name "number"]
[value ""]))
(input ([type "hidden"] [name "hidden"]
[value ,hidden]))
(input ([type "submit"] [name "enter"]
[value "Enter"]))))))
(define (many query)
;; Create a page containing the form:
(build-request-page "Number of greetings:" "/reply" ""))
(define (reply query)
;; Extract and use the form results:
(define n (string->number (cdr (assq 'number query))))
`(html (body ,@(for ([i (in-range n)])
" hello"))))
(hash-table-put! dispatch-table "many" many)
(hash-table-put! dispatch-table "reply" reply)

97
collects/scribblings/more/step7.txt Normal file
View File

@ -0,0 +1,97 @@
#lang scheme
;; There's only one change. It's in `accept-and-handle',
;; and it's marked with "<<<".
(require xml net/url)
(define (serve port-no)
(define main-cust (make-custodian))
(parameterize ([current-custodian main-cust])
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(thread loop))
(lambda ()
(custodian-shutdown-all main-cust)))
(define (accept-and-handle listener)
(define cust (make-custodian))
(custodian-limit-memory cust (* 50 1024 1024)) ;; <<< new line
(parameterize ([current-custodian cust])
(define-values (in out) (tcp-accept listener))
(thread (lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
;; Watcher thread:
(thread (lambda ()
(sleep 10)
(custodian-shutdown-all cust))))
(define (handle in out)
(define req
;; Match the first line to extract the request:
(regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+"
(read-line in)))
(when req
;; Discard the rest of the header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Dispatch:
(let ([xexpr (dispatch (list-ref req 1))])
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display (xexpr->string xexpr) out))))
(define (dispatch str-path)
;; Parse the request as a URL:
(define url (string->url str-path))
;; Extract the path part:
(define path (map path/param-path (url-path url)))
;; Find a handler based on the path's first element:
(define h (hash-table-get dispatch-table (car path) #f))
(if h
;; Call a handler:
(h (url-query url))
;; No handler found:
`(html (head (title "Error"))
(body
(font ((color "red"))
"Unknown page: "
,str-path)))))
(define dispatch-table (make-hash-table 'equal))
(hash-table-put! dispatch-table "hello"
(lambda (query)
`(html (body "Hello, World!"))))
;; ----------------------------------------
(define (build-request-page label next-url hidden)
`(html
(head (title "Enter a Number to Add"))
(body ([bgcolor "white"])
(form ([action ,next-url] [method "get"])
,label
(input ([type "text"] [name "number"]
[value ""]))
(input ([type "hidden"] [name "hidden"]
[value ,hidden]))
(input ([type "submit"] [name "enter"]
[value "Enter"]))))))
(define (many query)
;; Create a page containing the form:
(build-request-page "Number of greetings:" "/reply" ""))
(define (reply query)
;; Extract and use the form results:
(define n (string->number (cdr (assq 'number query))))
`(html (body ,@(for ([i (in-range n)])
" hello"))))
(hash-table-put! dispatch-table "many" many)
(hash-table-put! dispatch-table "reply" reply)

116
collects/scribblings/more/step8.txt Normal file
View File

@ -0,0 +1,116 @@
#lang scheme
;; No changes to old code --- just three new
;; functions and registrations at the end.
(require xml net/url)
(define (serve port-no)
(define main-cust (make-custodian))
(parameterize ([current-custodian main-cust])
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(thread loop))
(lambda ()
(custodian-shutdown-all main-cust)))
(define (accept-and-handle listener)
(define cust (make-custodian))
(custodian-limit-memory cust (* 50 1024 1024))
(parameterize ([current-custodian cust])
(define-values (in out) (tcp-accept listener))
(thread (lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
;; Watcher thread:
(thread (lambda ()
(sleep 10)
(custodian-shutdown-all cust))))
(define (handle in out)
(define req
;; Match the first line to extract the request:
(regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+"
(read-line in)))
(when req
;; Discard the rest of the header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Dispatch:
(let ([xexpr (dispatch (list-ref req 1))])
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display (xexpr->string xexpr) out))))
(define (dispatch str-path)
;; Parse the request as a URL:
(define url (string->url str-path))
;; Extract the path part:
(define path (map path/param-path (url-path url)))
;; Find a handler based on the path's first element:
(define h (hash-table-get dispatch-table (car path) #f))
(if h
;; Call a handler:
(h (url-query url))
;; No handler found:
`(html (head (title "Error"))
(body
(font ((color "red"))
"Unknown page: "
,str-path)))))
(define dispatch-table (make-hash-table 'equal))
(hash-table-put! dispatch-table "hello"
(lambda (query)
`(html (body "Hello, World!"))))
;; ----------------------------------------
(define (build-request-page label next-url hidden)
`(html
(head (title "Enter a Number to Add"))
(body ([bgcolor "white"])
(form ([action ,next-url] [method "get"])
,label
(input ([type "text"] [name "number"]
[value ""]))
(input ([type "hidden"] [name "hidden"]
[value ,hidden]))
(input ([type "submit"] [name "enter"]
[value "Enter"]))))))
(define (many query)
;; Create a page containing the form:
(build-request-page "Number of greetings:" "/reply" ""))
(define (reply query)
;; Extract and use the form results:
(define n (string->number (cdr (assq 'number query))))
`(html (body ,@(for ([i (in-range n)])
" hello"))))
(hash-table-put! dispatch-table "many" many)
(hash-table-put! dispatch-table "reply" reply)
;; ----------------------------------------
(define (sum query)
(build-request-page "First number:" "/one" ""))
(define (one query)
(build-request-page "Second number:"
"/two"
(cdr (assq 'number query))))
(define (two query)
(let ([n (string->number (cdr (assq 'hidden query)))]
[m (string->number (cdr (assq 'number query)))])
`(html (body "The sum is " ,(number->string (+ m n))))))
(hash-table-put! dispatch-table "sum" sum)
(hash-table-put! dispatch-table "one" one)
(hash-table-put! dispatch-table "two" two)

153
collects/scribblings/more/step9.txt Normal file
View File

@ -0,0 +1,153 @@
#lang scheme
;; See "<<<" for two small changes, then jump down
;; to `send/suspend'.
(require xml net/url
scheme/control) ;; <<< new import
(define (serve port-no)
(define main-cust (make-custodian))
(parameterize ([current-custodian main-cust])
(define listener (tcp-listen port-no 5 #t))
(define (loop)
(accept-and-handle listener)
(loop))
(thread loop))
(lambda ()
(custodian-shutdown-all main-cust)))
(define (accept-and-handle listener)
(define cust (make-custodian))
(custodian-limit-memory cust (* 50 1024 1024))
(parameterize ([current-custodian cust])
(define-values (in out) (tcp-accept listener))
(thread (lambda ()
(handle in out)
(close-input-port in)
(close-output-port out))))
;; Watcher thread:
(thread (lambda ()
(sleep 10)
(custodian-shutdown-all cust))))
(define (handle in out)
(define req
;; Match the first line to extract the request:
(regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+"
(read-line in)))
(when req
;; Discard the rest of the header (up to blank line):
(regexp-match #rx#"(\r\n|^)\r\n" in)
;; Dispatch:
(let ([xexpr (prompt (dispatch (list-ref req 1)))]) ;; <<< changed
;; Send reply:
(display "HTTP/1.0 200 Okay\r\n" out)
(display "Server: k\r\nContent-Type: text/html\r\n\r\n" out)
(display (xexpr->string xexpr) out))))
(define (dispatch str-path)
;; Parse the request as a URL:
(define url (string->url str-path))
;; Extract the path part:
(define path (map path/param-path (url-path url)))
;; Find a handler based on the path's first element:
(define h (hash-table-get dispatch-table (car path) #f))
(if h
;; Call a handler:
(h (url-query url))
;; No handler found:
`(html (head (title "Error"))
(body
(font ((color "red"))
"Unknown page: "
,str-path)))))
(define dispatch-table (make-hash-table 'equal))
(hash-table-put! dispatch-table "hello"
(lambda (query)
`(html (body "Hello, World!"))))
;; ----------------------------------------
(define (build-request-page label next-url hidden)
`(html
(head (title "Enter a Number to Add"))
(body ([bgcolor "white"])
(form ([action ,next-url] [method "get"])
,label
(input ([type "text"] [name "number"]
[value ""]))
(input ([type "hidden"] [name "hidden"]
[value ,hidden]))
(input ([type "submit"] [name "enter"]
[value "Enter"]))))))
(define (many query)
;; Create a page containing the form:
(build-request-page "Number of greetings:" "/reply" ""))
(define (reply query)
;; Extract and use the form results:
(define n (string->number (cdr (assq 'number query))))
`(html (body ,@(for ([i (in-range n)])
" hello"))))
(hash-table-put! dispatch-table "many" many)
(hash-table-put! dispatch-table "reply" reply)
;; ----------------------------------------
;; Old, awkward version:
(define (sum query)
(build-request-page "First number:" "/one" ""))
(define (one query)
(build-request-page "Second number:"
"/two"
(cdr (assq 'number query))))
(define (two query)
(let ([n (string->number (cdr (assq 'hidden query)))]
[m (string->number (cdr (assq 'number query)))])
`(html (body "The sum is " ,(number->string (+ m n))))))
(hash-table-put! dispatch-table "sum" sum)
(hash-table-put! dispatch-table "one" one)
(hash-table-put! dispatch-table "two" two)
;; ----------------------------------------
;; Helper to grab a computation and generate a handler for it:
(define (send/suspend mk-page)
(let/cc k
(define tag (format "k~a" (current-inexact-milliseconds)))
(hash-table-put! dispatch-table tag k)
(abort (mk-page (string-append "/" tag)))))
;; Helper to run the number-getting page via `send/suspend':
(define (get-number label)
(define query
;; Generate a URL for the current computation:
(send/suspend
;; Receive the computation-as-URL here:
(lambda (k-url)
;; Generate the query-page result for this connection.
;; Send the query result to the saved-computation URL:
(build-request-page label k-url ""))))
;; We arrive here later, in a new connection
(string->number (cdr (assq 'number query))))
;; ----------------------------------------
;; New direct-style servlet:
(define (sum2 query)
(define m (get-number "First number:"))
(define n (get-number "Second number:"))
`(html (body "The sum is " ,(number->string (+ m n)))))
(hash-table-put! dispatch-table "sum2" sum2)

2
collects/scribblings/quick/info.ss
View File

@ -1,4 +1,4 @@
(module info setup/infotab
(define name "Scribblings: Quick")
(define scribblings '(("quick.scrbl" ())))
(define doc-categories '((getting-started 1))))
(define doc-categories '((getting-started 2))))

14
collects/scribblings/quick/keep.ss Normal file
View File

@ -0,0 +1,14 @@
#lang scheme/base
(require scribble/struct
scheme/class)
(provide keep-file)
(define (keep-file file)
(make-delayed-element
(lambda (render part ri)
(send render install-file file)
null)
(lambda () 0)
(lambda () (make-element #f (list)))))

10
collects/scribblings/quick/quick.scrbl
View File

@ -6,6 +6,7 @@
@(require scribble/manual
"mreval.ss"
"keep.ss"
scribble/urls
scribble/struct
scheme/class
@ -19,15 +20,6 @@
(for-syntax scheme/base))
@(begin
(define (keep-file file)
(make-delayed-element
(lambda (render part ri)
(send render install-file file)
null)
(lambda () 0)
(lambda () (make-element #f (list))))))
@; ----------------------------------------------------------------------
This tutorial provides a brief introduction to the PLT Scheme

2
collects/scribblings/reference/security.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/doc
@require["mz.ss"]
@title[#:style 'toc]{Reflection and Security}
@title[#:style 'toc #:tag "security"]{Reflection and Security}
@local-table-of-contents[]

2
collects/scribblings/slideshow/slides.scrbl
View File

@ -411,7 +411,7 @@ The default assembler uses @scheme[titlet] to turn a title string (if
any) to a pict. See also @scheme[current-titlet] and
@scheme[set-title-h!],.
The slide assembler is @italic[not] responsible for adding page
The slide assembler is @emph{not} responsible for adding page
numbers to the slide; that job belongs to the viewer. See also
@scheme[current-page-number-font], @scheme[current-page-number-color],
and @scheme[set-page-numbers-visible!].}

11
collects/xml/main.ss Normal file
View File

@ -0,0 +1,11 @@
#lang scheme/base
(require "xml.ss")
(provide (except-out (all-from-out "xml.ss")
pi struct:pi pi? make-pi pi-target-name pi-instruction)
(rename-out [pi p-i]
[struct:pi struct:p-i]
[pi? p-i?]
[make-pi make-p-i]
[pi-target-name p-i-target-name]
[pi-instruction p-i-instruction]))