From b014545c7a7de0d7599a9383af830821f832ddb8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 16 Jan 2008 00:21:19 +0000 Subject: [PATCH] added 'more: systems' doc svn: r8341 --- collects/mzlib/control.ss | 11 +- collects/readline/main.ss | 4 + collects/readline/readline.scrbl | 25 +- collects/readline/rep.ss | 50 +- collects/scheme/enter.ss | 71 +- collects/scribblings/more/info.ss | 4 + collects/scribblings/more/more.scrbl | 810 ++++++++++++++++++ collects/scribblings/more/step0.txt | 4 + collects/scribblings/more/step1.txt | 22 + collects/scribblings/more/step2.txt | 31 + collects/scribblings/more/step3.txt | 31 + collects/scribblings/more/step4.txt | 36 + collects/scribblings/more/step5.txt | 76 ++ collects/scribblings/more/step6.txt | 100 +++ collects/scribblings/more/step7.txt | 97 +++ collects/scribblings/more/step8.txt | 116 +++ collects/scribblings/more/step9.txt | 153 ++++ collects/scribblings/quick/info.ss | 2 +- collects/scribblings/quick/keep.ss | 14 + collects/scribblings/quick/quick.scrbl | 10 +- collects/scribblings/reference/security.scrbl | 2 +- collects/scribblings/slideshow/slides.scrbl | 2 +- collects/xml/main.ss | 11 + 23 files changed, 1646 insertions(+), 36 deletions(-) create mode 100644 collects/readline/main.ss create mode 100644 collects/scribblings/more/info.ss create mode 100644 collects/scribblings/more/more.scrbl create mode 100644 collects/scribblings/more/step0.txt create mode 100644 collects/scribblings/more/step1.txt create mode 100644 collects/scribblings/more/step2.txt create mode 100644 collects/scribblings/more/step3.txt create mode 100644 collects/scribblings/more/step4.txt create mode 100644 collects/scribblings/more/step5.txt create mode 100644 collects/scribblings/more/step6.txt create mode 100644 collects/scribblings/more/step7.txt create mode 100644 collects/scribblings/more/step8.txt create mode 100644 collects/scribblings/more/step9.txt create mode 100644 collects/scribblings/quick/keep.ss create mode 100644 collects/xml/main.ss diff --git a/collects/mzlib/control.ss b/collects/mzlib/control.ss index ca925ba4bc..409d2a1435 100644 --- a/collects/mzlib/control.ss +++ b/collects/mzlib/control.ss @@ -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, diff --git a/collects/readline/main.ss b/collects/readline/main.ss new file mode 100644 index 0000000000..2c2221189c --- /dev/null +++ b/collects/readline/main.ss @@ -0,0 +1,4 @@ +#lang scheme + +(require "rep.ss") +(provide (all-from-out "rep.ss")) diff --git a/collects/readline/readline.scrbl b/collects/readline/readline.scrbl index 8b90e372e3..df7a024a4d 100644 --- a/collects/readline/readline.scrbl +++ b/collects/readline/readline.scrbl @@ -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. diff --git a/collects/readline/rep.ss b/collects/readline/rep.ss index 9f8a44c22f..d7aeb8d8d4 100644 --- a/collects/readline/rep.ss +++ b/collects/readline/rep.ss @@ -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)))))) diff --git a/collects/scheme/enter.ss b/collects/scheme/enter.ss index bb3cb79673..e350c68dd2 100644 --- a/collects/scheme/enter.ss +++ b/collects/scheme/enter.ss @@ -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)))))))))))))) diff --git a/collects/scribblings/more/info.ss b/collects/scribblings/more/info.ss new file mode 100644 index 0000000000..a42d2fe446 --- /dev/null +++ b/collects/scribblings/more/info.ss @@ -0,0 +1,4 @@ +(module info setup/infotab + (define name "Scribblings: More") + (define scribblings '(("more.scrbl" ()))) + (define doc-categories '((getting-started 1)))) diff --git a/collects/scribblings/more/more.scrbl b/collects/scribblings/more/more.scrbl new file mode 100644 index 0000000000..84e4555a4a --- /dev/null +++ b/collects/scribblings/more/more.scrbl @@ -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 +] + +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 "Hello, world!" 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") + +) diff --git a/collects/scribblings/more/step0.txt b/collects/scribblings/more/step0.txt new file mode 100644 index 0000000000..525b7202e2 --- /dev/null +++ b/collects/scribblings/more/step0.txt @@ -0,0 +1,4 @@ +#lang scheme + +(define (go) + 'yep-it-works) diff --git a/collects/scribblings/more/step1.txt b/collects/scribblings/more/step1.txt new file mode 100644 index 0000000000..759667d6db --- /dev/null +++ b/collects/scribblings/more/step1.txt @@ -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 "Hello, world!" out)) diff --git a/collects/scribblings/more/step2.txt b/collects/scribblings/more/step2.txt new file mode 100644 index 0000000000..f60442df11 --- /dev/null +++ b/collects/scribblings/more/step2.txt @@ -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 "Hello, world!" out)) diff --git a/collects/scribblings/more/step3.txt b/collects/scribblings/more/step3.txt new file mode 100644 index 0000000000..a196e2383e --- /dev/null +++ b/collects/scribblings/more/step3.txt @@ -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 "Hello, world!" out)) diff --git a/collects/scribblings/more/step4.txt b/collects/scribblings/more/step4.txt new file mode 100644 index 0000000000..842ef5d2b9 --- /dev/null +++ b/collects/scribblings/more/step4.txt @@ -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 "Hello, world!" out)) diff --git a/collects/scribblings/more/step5.txt b/collects/scribblings/more/step5.txt new file mode 100644 index 0000000000..eb02c699fb --- /dev/null +++ b/collects/scribblings/more/step5.txt @@ -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!")))) diff --git a/collects/scribblings/more/step6.txt b/collects/scribblings/more/step6.txt new file mode 100644 index 0000000000..659718b9b6 --- /dev/null +++ b/collects/scribblings/more/step6.txt @@ -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) diff --git a/collects/scribblings/more/step7.txt b/collects/scribblings/more/step7.txt new file mode 100644 index 0000000000..fb1a91ee53 --- /dev/null +++ b/collects/scribblings/more/step7.txt @@ -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) diff --git a/collects/scribblings/more/step8.txt b/collects/scribblings/more/step8.txt new file mode 100644 index 0000000000..fe5ca0828d --- /dev/null +++ b/collects/scribblings/more/step8.txt @@ -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) diff --git a/collects/scribblings/more/step9.txt b/collects/scribblings/more/step9.txt new file mode 100644 index 0000000000..51a76e5d40 --- /dev/null +++ b/collects/scribblings/more/step9.txt @@ -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) diff --git a/collects/scribblings/quick/info.ss b/collects/scribblings/quick/info.ss index e3a9b00de4..19bb761453 100644 --- a/collects/scribblings/quick/info.ss +++ b/collects/scribblings/quick/info.ss @@ -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)))) diff --git a/collects/scribblings/quick/keep.ss b/collects/scribblings/quick/keep.ss new file mode 100644 index 0000000000..6fce403cc2 --- /dev/null +++ b/collects/scribblings/quick/keep.ss @@ -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))))) diff --git a/collects/scribblings/quick/quick.scrbl b/collects/scribblings/quick/quick.scrbl index 3377137f86..33f0425c1f 100644 --- a/collects/scribblings/quick/quick.scrbl +++ b/collects/scribblings/quick/quick.scrbl @@ -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 diff --git a/collects/scribblings/reference/security.scrbl b/collects/scribblings/reference/security.scrbl index 8b4a85dd26..508b0d993f 100644 --- a/collects/scribblings/reference/security.scrbl +++ b/collects/scribblings/reference/security.scrbl @@ -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[] diff --git a/collects/scribblings/slideshow/slides.scrbl b/collects/scribblings/slideshow/slides.scrbl index da118103c1..0f0e9726d3 100644 --- a/collects/scribblings/slideshow/slides.scrbl +++ b/collects/scribblings/slideshow/slides.scrbl @@ -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!].} diff --git a/collects/xml/main.ss b/collects/xml/main.ss new file mode 100644 index 0000000000..96a0ab8a8a --- /dev/null +++ b/collects/xml/main.ss @@ -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]))