scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

...

1 Commits
main ... surflet-se

Author SHA1 Message Date
cvs-fast-export e1ec98d90b Synthetic commit for incomplete tag surflet-send-suspend-with-port 2003-01-22 12:53:46 +00:00
87 changed files with 0 additions and 15573 deletions

31
.gitignore vendored
View File

@ -1,31 +0,0 @@
# CVS default ignores begin
tags
TAGS
.make.state
.nse_depinfo
*~
\#*
.#*
,*
_$*
*$
*.old
*.bak
*.BAK
*.orig
*.rej
.del-*
*.a
*.olb
*.o
*.obj
*.so
*.exe
*.Z
*.elc
*.ln
core
# CVS default ignores end
test-packages.scm
test
SSAX

27
COPYING
View File

@ -1,27 +0,0 @@
Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
Copyright (c) 1996-2001 by Mike Sperber.
Copyright (c) 1999-2001 by Martin Gasbichler.
Copyright (c) 1998-2001 by Eric Marsden.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the authors may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

47
Makefile
View File

@ -1,47 +0,0 @@
SHELL = /bin/sh
version_id = 1.0
TEMPDIR = /tmp
sunet_files = Readme \
cgi-script.scm \
cgi-server.scm \
conditionals.scm \
crlf-io.scm \
htmlout.scm \
http-top.scm \
httpd/access-control.scm \
httpd/core.scm \
httpd/error.scm \
httpd/handlers.scm \
info-gateway.scm \
rman-gateway.scm \
modules.scm \
parse-forms.scm \
program-modules.scm \
rfc822.scm \
scheme-program-server.scm \
server.scm \
seval.scm \
smtp.scm \
stringhax.scm \
su-httpd.txt \
toothless.scm \
uri.scm \
url.scm
sunet-$(version_id).tar.gz: $(sunet_files)
sunet_root=`pwd`; \
mkdir $(TEMPDIR)/sunet-$(version_id); \
cp $(sunet_files) $(TEMPDIR)/sunet-$(version_id); \
cd $(TEMPDIR); \
tar czf sunet-$(version_id).tar.gz sunet-$(version_id); \
mv sunet-$(version_id).tar.gz $$sunet_root; \
rm -rf sunet-$(version_id)
.PHONY: tags
tags:
find . -name "*.scm" | etags -

47
Readme
View File

@ -1,47 +0,0 @@
The SU Net package, version 1.0
===============================
This directory contains my code for doing Net hacking from Scheme/scsh.
It includes:
An smtp client library.
Forge mail from the comfort of your own Scheme process.
rfc822 header library
Read email-style headers. Useful in several contexts (smtp, http, etc.)
Simple structured HTML output library
Balanced delimiters, etc. htmlout.scm.
HTTP server library
This is a complete implementation of an HTTP 1.0 server.
The server is very extensible, via a mechanism called "path handlers."
The library includes other standalone libraries that may be of use:
+ URI and URL parsers and unparsers.
+ A library to help writing CGI scripts in Scheme.
+ Server extensions for interfacing to CGI scripts.
+ Server extensions for uploading Scheme code.
-------------------------------------------------------------------------------
Note well:
- You can't do serious programming in Scheme within the bounds of R4RS.
I work in Scheme 48 and scsh. Every file does have a comment header
describing its non-R4RS dependencies, should you decide to try porting
it to another Scheme.
- Only simple documentation, but my code is written in my usual style --
voluminously commented.
-Olin
-------------------------------------------------------------------------------
Note further:
The net package is currently being maintained by Mike Sperber
<sperber@informatik.uni-tuebingen.de>.
My main focus for further development is on making the HTTP server
into a realistic full-blown package, but I'll gladly accept patches
and suggestions for the other parts of the net package.
-Mike
And: See the doc directory for further informations.

85
doc/html/index.html
View File

@ -1,85 +0,0 @@
<HTML>
<HEAD>
<TITLE>The Scheme Underground Network Package</TITLE>
</HEAD>
<BODY>
<H1>The Scheme Underground Network Package</H1>
I have written a set of libraries for doing Net hacking from Scheme/scsh.
It includes:
<DL>
<DT> An smtp client library.
<DD> Forge mail from the comfort of your own Scheme process.
<DT> rfc822 header library
<DD> Read email-style headers. Useful in several contexts (smtp, http, etc.)
<DT> Simple structured HTML output library
<DD> Balanced delimiters, etc.
<DT> The SU Web server
<DD> This is a complete implementation of an HTTP 1.0 server in Scheme.
The server contains other standalone packages that may separately be of
use:
<UL>
<LI> URI and URL parsers and unparsers.
<LI> A library to help writing CGI scripts in Scheme.
<LI> Server extensions for interfacing to CGI scripts.
<LI> Server extensions for uploading Scheme code.
</UL>
The server has three main design goals:
<DL>
<DT> Extensibility
<DD> The server is in fact nothing but extensions, using a mechanism
called "path handlers" to define URL-specific services. It has a toolkit
of services that can be used as-is, extended or built upon.
User extensions have exactly the same status as the base services.
<P>
The extension mechanism allows for easy implementation of new services
without the overhead of the CGI interface. Since the server is written
on top of the Scheme shell, the full set of Unix system calls and
program tools is available to the implementor.
<DT> Mobile code
<DD> The server allows Scheme code to be uploaded for direct execution
inside the server. The server has complete control over the code,
and can safely execute it in restricted environments that do not
provide access to potentially dangerous primitives (such as the
"delete file" procedure.)
<DT> Clarity
<DD> I wrote this server to help myself understand the Web. It is voluminously
commented, and I hope it will prove to be an aid in understanding the
low-level details of the Web protocols.
</DL>
<P>
The S.U. server has the ability to upload code from Web clients and
execute that code on behalf of the client in a protected environment.
<P>
Some <A HREF="su-httpd.html">simple documentation</A> on the server
is available.
</DL>
<H2>Obtaining the system</H2>
The network code is available by
<A HREF="ftp://ftp-swiss.ai.mit.edu/pub/scsh/contrib/net/net.tar.gz">ftp</A>.
To run the server, you need our 0.4 release of
<A HREF="http://www-swiss.ai.mit.edu/scsh/scsh.html">scsh</A>
which has just been released.
Beyond actually running the server,
the separate parser libraries and other utilites may be of use as separate
modules.
<ADDRESS><A HREF="http://www.ai.mit.edu/people/shivers/">Olin Shivers</A>
/ <A HREF="plan-file">shivers@ai.mit.edu</A></ADDRESS>
</BODY>
</HTML>

482
doc/html/su-httpd.html
View File

@ -1,482 +0,0 @@
<!-- check for *..* emphasis, etc., i.e., e.g. -->
<HTML>
<HEAD>
<TITLE>The Scheme Underground Web system</TITLE>
</HEAD>
<BODY>
<H1>The Scheme Underground Web System</H1>
<ADDRESS><A HREF="http://www.ai.mit.edu/people/shivers/">Olin Shivers</A>
/ <A HREF="plan-file">shivers@ai.mit.edu</A>
</ADDRESS>
July 1995
<BLOCKQUOTE>
Note: Netscape typesets description lists in a manner that makes the
procedure descriptions below blur together, even in the absence of the
HTML COMPACT attribute. You may just wish to print out a simple
<A HREF="su-httpd.txt">ASCII version</A> of this note, instead.
</BLOCKQUOTE>
<!---------------------------------------------------------------------------->
<H2>Introduction</H2>
The
<A HREF="http://www.ai.mit.edu/projects/su/su.html">Scheme underground</A>
Web system is a package of
<A HREF="http://www-swiss.ai.mit.edu/scheme-home.html">Scheme</A>
code that provides
utilities for interacting with the
<A HREF="http://www.w3.org/">World-Wide Web</A>.
This includes:
<UL>
<LI> A Web server.
<LI> URI and URL parsers and un-parsers.
<LI> RFC822-style header parsers.
<LI> Code for performing structured html output
<LI> Code to assist in writing CGI Scheme programs
that can be used by any CGI-compliant HTTP server
(such as NCSA's httpd, or the S.U. Web server).
</UL>
<P>
The code can be obtained via
<A HREF="ftp://ftp-swiss.ai.mit.edu/pub/scsh/contrib/net/net.tar.gz">
anonymous ftp</A>
and is implemented in
<A HREF="http://www-swiss.ai.mit.edu/~jar/s48.html">Scheme 48</A>,
using the system calls and support procedures of
<A HREF="http://www-swiss.ai.mit.edu/scsh/scsh.html">scsh</A>,
the Scheme Shell.
The code was written to be clear and modifiable --
it is voluminously commented and all non-R4RS dependencies are
described at the beginning of each source file.
<P>
I do not have the time to write detailed documentation for these packages.
However, they are very thoroughly commented, and I strongly recommend
reading the source files; they were written to be read, and the source
code comments should provide a clear description of the system.
The remainder of this note gives an overview of the server's basic
architecture and interfaces.
<H2>The Scheme Underground Web Server</H2>
The server was designed with three principle goals in mind:
<DL>
<DT> Extensibility
<DD> The server is designed to make it easy to extend the basic
functionality. In fact, the server is nothing but extensions. There is
no distinction between the set of basic services provided by the server
implementation and user extensions -- they are both implemented in
Scheme, and have equal status. The design is "turtles all the way down."
<DT> Mobile code
<DD> Because the server is written in Scheme 48, it is simple to use the
Scheme 48 module system to upload programs to the server for safe
execution within a protected, server-chosen environment. The server
comes with a simple example upload service to demonstrate this
capability.
<DT> Clarity of implementation
<DD> Because the server is written in a high-level language, it should make
for a clearer exposition of the HTTP protocol and the associated URL
and URI notations than one written in a low-level language such as C.
This also should help to make the server easy to modify and adapt to
different uses.
</DL>
<!---------------------------------------------------------------------------->
<H3>Basic server structure</H3>
The Web server is started by calling the <CODE>httpd</CODE> procedure,
which takes one required and two optional arguments:
<PRE>
(httpd <VAR>path-handler</VAR> [<VAR>port</VAR> <VAR>working-directory</VAR>])
</PRE>
The server accepts connections from the given port, which defaults to 80.
The server runs with the working directory set to the given value,
which defaults to
<PRE>
/usr/local/etc/httpd
</PRE>
<P>
The server's basic loop is to wait on the port for a connection from an HTTP
client. When it receives a connection, it reads in and parses the request into
a special request data structure. Then the server forks a child process, who
binds the current I/O ports to the connection socket, and then hands off to
the top-level path handler (the first argument to <CODE>httpd</CODE>).
The path-handler procedure is responsible for actually serving the request --
it can be any arbitrary computation.
Its output goes directly back to the HTTP client that sent the request.
<P>
Before calling the path handler to service the request, the HTTP server
installs an error handler that fields any uncaught error, sends an
error reply to the client, and aborts the request transaction. Hence
any error caused by a path-handler will be handled in a reasonable and
robust fashion.
<P>
The basic server loop, and the associated request data structure are the fixed
architecture of the S.U. Web server; its flexibility lies in the notion of
path handlers.
<!---------------------------------------------------------------------------->
<H3>Path handlers</H3>
A path handler is a procedure taking two arguments:
<PRE>
(path-handler <VAR>path</VAR> <VAR>req</VAR>)
</PRE>
The <VAR>req</VAR> argument is a request record giving all the details of the
client's request; it has the following structure:
<PRE>
(define-record request
method ; A string such as "GET", "PUT", etc.
uri ; The escaped URI string as read from request line.
url ; An http URL record (see url.scm).
version ; A (major . minor) integer pair.
headers ; An rfc822 header alist (see rfc822.scm).
socket) ; The socket connected to the client.
</PRE>
The <VAR>path</VAR> argument is the URL's path,
parsed and split at slashes into a string list.
For example, if the Web client dereferences URL
<PRE>
http://clark.lcs.mit.edu:8001/h/shivers/code/web.tar.gz
</PRE>
then the server would pass the following path to the top-level handler:
<PRE>
("h" "shivers" "code" "web.tar.gz")
</PRE>
<P>
The path argument's pre-parsed representation as a string list makes it easy
for the path handler to implement recursive operations dispatch on URL paths.
<P>
Path handlers can do anything they like to respond to HTTP requests; they have
the full range of Scheme to implement the desired functionality. When
handling HTTP requests that have an associated entity body (such as POST), the
body should be read from the current input port. Path handlers should in all
cases write their reply to the current output port. Path handlers should
<EM>not</EM> perform I/O on the request record's socket.
Path handlers are frequently called recursively, and doing I/O directly to the
socket might bypass a filtering or other processing step interposed on the
current I/O ports by some superior path handler.
<!---------------------------------------------------------------------------->
<H3>Basic path handlers</H3>
Although the user can write any path-handler he likes, the S.U. server comes
with a useful toolbox of basic path handlers that can be used and built upon:
<DL>
<DT>
<CODE>(alist-path-dispatcher <VAR>ph-alist</VAR> <VAR>default-ph</VAR>) -> <VAR>path-handler</VAR>
</CODE>
<DD>
This procedure takes a string->path-handler alist, and a default
path handler, and returns a handler that dispatches on its path argument.
When the new path handler is applied to a path
<CODE>("foo" "bar" "baz")</CODE>,
it uses the first element of the path -- <CODE>"foo"</CODE> -- to
index into the alist.
If it finds an associated path handler in the alist, it
hands the request off to that handler, passing it the tail of the
path, <CODE>("bar" "baz")</CODE>.
On the other hand, if the path is empty, or the alist search does
not yield a hit, we hand off to the default path handler,
passing it the entire original path, <CODE>("foo" "bar" "baz")</CODE>.
<P>
This procedure is how you say: "If the first element of the URL's path
is `foo', do X; if it's `bar', do Y; otherwise, do Z." If one takes
an object-oriented view of the process, an alist path-handler does
method lookup on the requested operation, dispatching off to the
appropriate method defined for the URL.
<P>
The slash-delimited URI path structure implies an associated
tree of names. The path-handler system and the alist dispatcher
allow you to procedurally define the server's response to any arbitrary
subtree of the path space.
<P>
Example: <br>
A typical top-level path handler is
<PRE>
(define ph
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html"))
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))
("seval" . ,seval-handler))
(rooted-file-handler "/usr/local/etc/httpd/htdocs")))
</PRE>
This means:
<UL>
<LI> If the path looks like <CODE>("h" "shivers" "code" "web.tar.gz")</CODE>,
pass the path <CODE>("shivers" "code" "web.tar.gz")</CODE> to a
home-directory path handler.
<LI> If the path looks like <CODE>("cgi-bin" "calendar")</CODE>,
pass <CODE>("calendar")</CODE> off to the CGI path handler.
<LI> If the path looks like <CODE>("seval" ...)</CODE>,
the tail of the path is passed off to the code-uploading seval
path handler.
<LI> Otherwise, the whole path is passed to a rooted file handler, who
will convert it into a filename, rooted at
<CODE>/usr/local/etc/httpd/htdocs</CODE>, and serve that file.
</UL>
<DT> <CODE>(home-dir-handler <VAR>subdir</VAR>) ->
<VAR>path-handler</CODE></VAR>
<DD>
This procedure builds a path handler that does basic file serving
out of home directories. If the resulting path handler is passed
a path of <CODE>(<VAR>user</VAR> . <VAR>file-path</VAR>)</CODE>,
then it serves the file
<PRE>
<VAR>user's-home-directory</VAR>/<VAR>subdir</VAR>/<VAR>file-path</VAR>
</PRE>
The path handler only handles GET requests; the filename is not
allowed to contain <CODE>..</CODE> elements.
<DT>
<CODE>(tilde-home-dir-handler <VAR>subdir</VAR> <VAR>default-path-handler</VAR>)
-> <VAR>path-handler</VAR>
</CODE>
<DD>
This path handler examines the car of the path. If it is a string
beginning with a tilde, <em>e.g.</em>, "<CODE>~ziggy</CODE>",
then the string is taken
to mean a home directory, and the request is served similarly to a
<CODE>home-dir-handler</CODE> path handler.
Otherwise, the request is passed off
in its entirety to the default path handler.
<P>
This procedure is useful for implementing servers that provide the
semantics of the NCSA httpd server.
<DT>
<CODE>(cgi-handler <VAR>cgi-directory</VAR>) -> <VAR>path-handler</VAR>
</CODE>
<DD>
This procedure returns a path-handler that passes the request off to some
program using the CGI interface. The script name is taken from the
car of the path; it is checked for occurrences of <CODE>..</CODE>'s.
If the path is
<PRE>
("my-prog" "foo" "bar")
</PRE>
then the program executed is
<PRE>
<VAR>cgi-directory</VAR>/my-prog
</PRE>
<P>
When the CGI path handler builds the process environment for the
CGI script, several elements
(<em>e.g.</em>, <CODE>$PATH</CODE> and <CODE>$SERVER_SOFTWARE</CODE>)
are request-invariant, and can be computed at server start-up time.
This can be done by calling
<PRE>
(initialise-request-invariant-cgi-env)
</PRE>
when the server starts up. This is <EM>not</EM> necessary,
but will make CGI requests a little faster.
<DT>
<CODE>(rooted-file-handler <VAR>root-dir</VAR>) -> <VAR>path-handler</VAR>
</CODE>
<DD>
Returns a path handler that serves files from a particular root
in the file system. Only the GET operation is provided. The path
argument passed to the handler is converted into a filename,
and appended to <VAR>root-dir</VAR>.
The file name is checked for <CODE>..</CODE> components,
and the transaction is aborted if it does. Otherwise, the file is
served to the client.
<DT>
<CODE>(null-path-handler <VAR>path</VAR> <VAR>req</VAR>)</CODE>
<DD>
This path handler is useful as a default handler. It handles no requests,
always returning a "404 Not found" reply to the client.
</DL>
<!---------------------------------------------------------------------------->
<H3>HTTP errors</H3>
Authors of path-handlers need to be able to handle errors in a reasonably
simple fashion. The S.U. Web server provides a set of error conditions that
correspond to the error replies in the HTTP protocol. These errors can be
raised with the <CODE>http-error</CODE> procedure.
When the server runs a path handler,
it runs it in the context of an error handler that catches these errors,
sends an error reply to the client, and closes the transaction.
<DL>
<DT>
<CODE>(http-error <VAR>reply-code</VAR> <VAR>req</VAR> [<VAR>extra</VAR> ...])</CODE>
<DD>
This raises an http error condition. The reply code is one of the
numeric HTTP error reply codes, which are bound to the variables
<CODE>http-reply/ok</CODE>, <CODE>http-reply/not-found</CODE>,
<CODE>http-reply/bad-request</CODE>, and so
forth. The <VAR>req</VAR> argument is the request record that caused
the error.
Any following <VAR>extra</VAR> args are passed along for
informational purposes.
Different HTTP errors take different types of extra arguments.
For example, the "301 moved permanently" and "302 moved temporarily"
replies use the first two <VAR>extra</VAR> values as the
<CODE>URI:</CODE> and <CODE>Location:</CODE>
fields in the reply header, respectively. See the clauses of the
<CODE>send-http-error-reply</CODE> procedure for details.
<DT>
<CODE>(send-http-error-reply <VAR>reply-code</VAR> <VAR>request</VAR>
[<VAR>extra</VAR> ...])
</CODE>
<DD>
This procedure writes an error reply out to the current output
port. If an error occurs during this process, it is caught, and
the procedure silently returns. The http server's standard error
handler passes all http errors raised during path-handler execution
to this procedure to generate the error reply before aborting the
request transaction.
</DL>
<!---------------------------------------------------------------------------->
<H3>Simple directory generation</H3>
Most path-handlers that serve files to clients eventually call an internal
procedure named <CODE>file-serve</CODE>,
which implements a simple directory-generation service using the
following rules:
<UL>
<LI> If the filename has the <EM>form</EM> of a directory
(<EM>i.e.</EM>, it ends with a slash),
then <CODE>file-serve</CODE> actually looks for a
file named "<CODE>index.html</CODE>" in that directory.
<LI> If the filename names a directory, but is not in directory form
(<EM>i.e.</EM>, it doesn't end in a slash,
as in "<CODE>/usr/include</CODE>" or "<CODE>/usr/raj</CODE>"),
then <CODE>file-serve</CODE> sends back a "301 moved permanently"
message,
redirecting the client to a slash-terminated version of the original
URL. For example, the URL
<PRE>
http://clark.lcs.mit.edu/~shivers
</PRE>
would be redirected to
<PRE>
http://clark.lcs.mit.edu/~shivers/
</PRE>
<LI> If the filename names a regular file, it is served to the client.
</UL>
<!---------------------------------------------------------------------------->
<H3>Support procs</H3>
The source files contain a host of support procedures which will be of utility
to anyone writing a custom path-handler. Read the files first.
<!---------------------------------------------------------------------------->
<H3>Losing</H3>
Be aware of two Unix problems, which may require workarounds:
<OL>
<LI>
NeXTSTEP's Posix implementation of the <CODE>getpwnam()</CODE> routine
will silently tell you that every user has uid 0. This means
that if your server, running as root, does a
<PRE>
(set-uid (user->uid "nobody"))
</PRE>
it will essentially do a
<PRE>
(set-uid 0)
</PRE>
and you will thus still be running as root.
<P>
The fix is to manually find out who user nobody is (he's -2 on my
system), and to hard-wire this into the server:
<PRE>
(set-uid -2)
</PRE>
This problem is NeXTSTEP specific. If you are using not using NeXTSTEP,
no problem.
<LI>
On NeXTSTEP, the ip-address->host-name translation routine
(in C, <CODE>gethostbyaddr()</CODE>; in scsh,
<CODE>(host-info addr)</CODE>) does not
use the DNS system; it goes through NeXT's propietary Netinfo
system, and may not return a fully-qualified domain name. For
example, on my system, I get "amelia-earhart", when I want
"amelia-earhart.lcs.mit.edu". Since the server uses this name
to construct redirection URL's to be sent back to the Web client,
they need to be FQDN's.
<P>
This problem may occur on other OS's;
I cannot determine if <CODE>gethostbyaddr()</CODE>
is required to return a FQDN or not. (I would appreciate hearing the
answer if you know; my local Internet guru's couldn't tell me.)
<P>
If your system doesn't give you a complete Internet address when
you say
<PRE>
(host-info:name (host-info (system-name)))
</PRE>
then you have this problem.
<P>
The server has a workaround. There is a procedure exported from
the httpd-core package:
<PRE>
(set-my-fqdn name)
</PRE>
Call this to crow-bar the server's idea of its own Internet host name
before running the server, and all will be well.
</OL>
</BODY>
</HTML>

7
doc/latex/.gitignore vendored
View File

@ -1,7 +0,0 @@
*.aux
*.toc
*.dvi
*.ps
*.pdf
*.log

1
doc/latex/.tex2page.hdir
View File

@ -1 +0,0 @@
../../web-server/root/htdocs/sunet-manual

24
doc/latex/cgi-script.tex
View File

@ -1,24 +0,0 @@
\chapter{Writing CGI Scripts in Scheme}\label{cha:cgi-scripts}
%
The \ex{cgi-scripts} structure provides functionality useful for
writing CGI scripts in Scheme.
\defun{cgi-form-query}{}{data-alist}
\begin{desc}
CGI scripts receive their parameters in various ways, depending on
how they were called (e.g.\ by \ex{GET} method).
This procedure translates the delivered form data into an alist of
decoded strings, using the environment variables set by the server
(\ex{REQUEST\_METHOD}, \ex{QUERY\_STRING} (for a \ex{GET} request),
\ex{CONTENT\_LENGTH} (for a \ex{POST} request)). So a query string
like \codex{button=on\&\ob{}reply=Oh,\ob{}\%20yes} becomes an alist
\codex{(("button" . "on") ("reply" . "Oh, yes"))}
\ex{Cgi-form-query} only works for \ex{GET} and \ex{POST} methods.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

296
doc/latex/code.sty
View File

@ -1,296 +0,0 @@
% code.sty: -*- latex -*-
% Latex macros for a "weak" verbatim mode.
% -- like verbatim, except \, {, and } have their usual meanings.
% Environments: code, tightcode, codeaux, codebox, centercode
% Commands: \dcd, \cddollar, \cdmath, \cd, \codeallowbreaks, \codeskip, \^
% Already defined in LaTeX, but of some relevance: \#, \$, \%, \&, \_, \{, \}
% Changelog at the end of the file.
% These commands give you an environment, code, that is like verbatim
% except that you can still insert commands in the middle of the environment:
% \begin{code}
% for(x=1; x<loop_bound; x++)
% y += x^3; /* {\em Add in {\tt x} cubed} */
% \end{code}
%
% All characters are ordinary except \{}. To get \{} in your text,
% you use the commands \\, \{, and \}.
% These macros mess with the definition of the special chars (e.g., ^_~%).
% The characters \{} are left alone, so you can still have embedded commands:
% \begin{code} f(a,b,\ldots,y,z) \end{code}
% However, if your embedded commands use the formerly-special chars, as in
% \begin{code} x := x+1 /* \mbox{\em This is $y^3$} */ \end{code}
% then you lose. The $ and ^ chars are scanned in as non-specials,
% so they don't work. If the chars are scanned *outside* the code env,
% then you have no problem:
% \def\ycube{$y^3$}
% \begin{code} x := x+1 /* {\em This is \ycube} */ \end{code}
% If you must put special chars inside the code env, you do it by
% prefixing them with the special \dcd ("decode") command, that
% reverts the chars to back to special status:
% \begin{code} x := x+1 /* {\dcd\em This is $y^3$} */ \end{code}
% \dcd's scope is bounded by its enclosing braces. It is only defined within
% the code env. You can also turn on just $ with the \cddollar command;
% you can turn on just $^_ with the \cdmath command. See below.
%
% Alternatively, just use \(...\) for $...$, \sp for ^, and \sb for _.
% WARNING:
% Like \verb, you cannot put a \cd{...} inside an argument to a macro
% or a command. If you try, for example,
% \mbox{\cd{$x^y$}}
% you will lose. That is because the text "\cd{$x^y$}" gets read in
% as \mbox's argument before the \cd executes. But the \cd has to
% have a chance to run before LaTeX ever reads the $x^y$ so it can
% turn off the specialness of $ and ^. So, \cd has to appear at
% top level, not inside an argument. Similarly, you can't have
% a \cd or a \code inside a macro (Although you could use \gdef to
% define a macro *inside* a \cd, which you could then use outside.
% Don't worry about this if you don't understand it.)
% BUG: In the codebox env, the effect of a \dcd, \cddollar, or \cdmath
% command is reset at the end of each line. This can be hacked by
% messing with the \halign's preamble, if you feel up to it.
% Useage note: the initial newline after the \begin{code} or
% \begin{codebox} is eaten, but the last newline is not.
% So,
% \begin{code}
% foo
% bar
% \end{code}
% leaves one more blank line after bar than does
% \begin{code}
% foo
% bar\end{code}
% Moral: get in the habit of terminating code envs without a newline
% (as in the second example).
%
% All this stuff tweaks the meaning of space, tab, and newline.
%===============================================================================
% \cd@obeyspaces
% Turns all spaces into non-breakable spaces.
% Note: this is like \@vobeyspaces except without spurious space in defn.
% @xobeysp is basically a space; it's defined in latex.tex.
%
{\catcode`\ =\active\gdef\cd@obeyspaces{\catcode`\ =\active\let =\@xobeysp}}
% \cd@obeytabs
% Turns all tabs into 8 non-breakable spaces (which is bogus).
%
{\catcode`\^^I=\active %
\gdef\cd@obeytabs{\catcode`\^^I=\active\let^^I=\cd@tab}}
\def\cd@tab{\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp}
% \cd@obeylines
% Turns all cr's into linebreaks. Pagebreaks are not permitted between lines.
% This is copied from lplain.tex's \obeylines, with the cr def'n changed.
%
{\catcode`\^^M=\active % these lines must end with %
\gdef\cd@obeylines{\catcode`\^^M=\active\let^^M=\cd@cr}}
% What ^M turns into. This def'n keeps blank lines from being compressed out.
\def\cd@cr{\par\penalty10000\leavevmode} % TeX magicness
%\def\cd@cr{\par\penalty10000\mbox{}} % LaTeX
% \codeallowbreaks
% Same as \cd@obeylines, except pagebreaks are allowed.
% Put this command inside a code env to allow pagebreaks.
{\catcode`\^^M=\active % these lines must end with %
\gdef\codeallowbreaks{\catcode`\^^M\active\let^^M\cd@crbr}}
%\def\cd@crbr{\leavevmode\endgraf} % What ^M turns into.
\def\cd@crbr{\par\leavevmode} % What ^M turns into.
% \cd@obeycrsp
% Turns cr's into non-breakable spaces. Used by \cd.
{\catcode`\^^M=\active % these lines must end with %
\gdef\cd@obeycrsp{\catcode`\^^M=\active\let^^M=\@xobeysp}}
% =============================================================================
% Set up code environment, in which most of the common special characters
% appearing in code are treated verbatim, namely: $&#^_~%
% \ { } are still enabled so that macros can be called in this
% environment. Use \\, \{, and \} to use these characters verbatim
% in this environment.
%
% Inside a group, you can make
% all the hacked chars special with the \dcd command
% $ special with the \cddollar command
% $^_ special with the \cdmath command.
% If you have a bunch of math $..$'s in your code env, then a global \cddollar
% or \cdmath at the beginning of the env can save a lot of trouble.
% When chars are special (e.g., after a \dcd), you can still get #$%&_{} with
% \#, \$, \%, \&, \_, \{, and \} -- this is standard LaTeX.
% Additionally, \\ gives \ inside the code env, and when \cdmath
% makes ^ special, it also defines \^ to give ^.
%The hacked characters can be made special again
% within a group by using the \dcd command.
% Note: this environment allows no breaking of lines whatsoever; not
% at spaces or hypens. To arrange for a break use the standard \- command,
% or a \discretionary{}{}{} which breaks, but inserts nothing. This is useful,
% for example for allowing hypenated identifiers to be broken, e.g.
% \def\={\discretionary{}{}{}} %optional break
% FOO-\=BAR.
\def\setupcode{\parsep=0pt\parindent=0pt%
\normalfont\ttfamily\frenchspacing\catcode``=13\@noligs%
\def\\{\char`\\}%
\let\dcd=\cd@dcd\let\cddollar=\cd@dollarspecial\let\cdmath=\cd@mathspecial%
\@makeother\$\@makeother\&\@makeother\#%
\@makeother\^\@makeother\_\@makeother\~%
\@makeother\%\cd@obeytabs\cd@obeyspaces}
% other: $&#^_~%
% left special: \{}
% unnecessary: @`'"
%% codebox, centercode
%%=============================================================================
%% The codebox env makes a box exactly as wide as it needs to be
%% (i.e., as wide as the longest line of code is). This is useful
%% if you want to center a chunk of code, or flush it right, or
%% something like that. The optional argument to the environment,
%% [t], [c], or [b], specifies how to vertically align the codebox,
%% just as with arrays or other boxes. Default is [c].
%% Must be a newline immediately after "\begin{codebox}[t]"!
{\catcode`\^^M=\active % these lines must end with %
\gdef\cd@obeycr{\catcode`\^^M=\active\let^^M=\cr}}
% If there is a [<letter>] option, then the following newline will
% be read *after* ^M is bound to \cr, so we're cool. If there isn't
% an option given (i.e., default to [c]), then the @\ifnextchar will
% gobble up the newline as it gobbles whitespace. So we insert the
% \cr explicitly. Isn't TeX fun?
\def\codebox{\leavevmode\@ifnextchar[{\@codebox}{\@codebox[c]\cr}} %]
\def\@codebox[#1]%
{\hbox\bgroup$\if #1t\vtop \else \if#1b\vbox \else \vcenter \fi\fi\bgroup%
\tabskip\z@\setupcode\cd@obeycr% just before cd@obey
\halign\bgroup##\hfil\span}
\def\endcodebox{\crcr\egroup\egroup\m@th$\egroup}
% Center the box on the page:
\newenvironment{centercode}%
{\begin{center}\begin{codebox}[c]}%
{\end{codebox}\end{center}}
%% code, codeaux, tightcode
%%=============================================================================
%% Code environment as described above. Lines are kept on one page.
%% This actually works by setting a huge penalty for breaking
%% between lines of code. Code is indented same as other displayed paras.
%% Note: to increase left margin, use \begin{codeaux}{\leftmargin=1in}.
% To allow pagebreaks, say \codeallowbreaks immediately inside the env.
% You can allow breaks at specific lines with a \pagebreak form.
%% N.B.: The \global\@ignoretrue command must be performed just inside
%% the *last* \end{...} before the following text. If not, you will
%% get an extra space on the following line. Blech.
%% This environment takes two arguments.
%% The second, required argument is the \list parameters to override the
%% \@listi... defaults.
%% - Usefully set by clients: \topsep \leftmargin
%% - Possible, but less useful: \partopsep
%% The first, optional argument is the extra \parskip glue that you get around
%% \list environments. It defaults to the value of \parskip.
\def\codeaux{\@ifnextchar[{\@codeaux}{\@codeaux[\parskip]}} %]
\def\@codeaux[#1]#2{%
\bgroup\parskip#1%
\begin{list}{}%
{\parsep\z@\rightskip\z@\listparindent\z@\itemindent\z@#2}%
\item[]\setupcode\cd@obeylines}%
\def\endcodeaux{\end{list}\leavevmode\egroup\ignorespaces\global\@ignoretrue}
%% Code env is codeaux with the default margin and spacing \list params:
\def\code{\codeaux{}} \let\endcode=\endcodeaux
%% Like code, but with no extra vertical space above and below.
\def\tightcode{\codeaux[=0pt]{\topsep\z@}}%
\let\endtightcode\endcodeaux
% {\vspace{-1\parskip}\begin{codeaux}{\partopsep\z@\topsep\z@}}%
% {\end{codeaux}\vspace{-1\parskip}}
% Reasonable separation between lines of code
\newcommand{\codeskip}{\penalty0\vspace{2ex}}
% \cd is used to build a code environment in the middle of text.
% Note: only difference from display code is that cr's are taken
% as unbreakable spaces instead of linebreaks.
\def\cd{\leavevmode\begingroup\ifmmode\let\startcode=\startmcode\else%
\let\startcode\starttcode\fi%
\setupcode\cd@obeycrsp\startcode}
\def\starttcode#1{#1\endgroup}
\def\startmcode#1{\hbox{#1}\endgroup}
% Restore $&#^_~% to their normal catcodes
% Define \^ to give the ^ char.
% \dcd points to this guy inside a code env.
\def\cd@dcd{\catcode`\$=3\catcode`\&=4\catcode`\#=6\catcode`\^=7%
\catcode`\_=8\catcode`\~=13\catcode`\%=14\def\^{\char`\^}}
% Selectively enable $, and $^_ as special.
% \cd@mathspecial also defines \^ give the ^ char.
% \cddollar and \cdmath point to these guys inside a code env.
\def\cd@dollarspecial{\catcode`\$=3}
\def\cd@mathspecial{\catcode`\$=3\catcode`\^=7\catcode`\_=8%
\def\^{\char`\^}}
% Change log:
% Started off as some macros found in C. Rich's library.
% Olin 1/90:
% Removed \makeatletter, \makeatother's -- they shouldn't be there,
% because style option files are read with makeatletter. The terminal
% makeatother screwed things up for the following style options.
% Olin 3/91:
% Rewritten.
% - Changed things so blank lines don't get compressed out (the \leavevmove
% in \cd@cr and \cd@crwb).
% - Changed names to somewhat less horrible choices.
% - Added lots of doc, so casual hackers can more easily mess with all this.
% - Removed `'"@ from the set of hacked chars, since they are already
% non-special.
% - Removed the bigcode env, which effect can be had with the \codeallowbreaks
% command.
% - Removed the \@noligs command, since it's already defined in latex.tex.
% - Win big with the new \dcd, \cddollar, and \cdmath commands.
% - Now, *only* the chars \{} are special inside the code env. If you need
% more, use the \dcd command inside a group.
% - \cd now works inside math mode. (But if you use it in a superscript,
% it still comes out full size. You must explicitly put a \scriptsize\tt
% inside the \cd: $x^{\cd{\scriptsize\tt...}}$. A \leavevmode was added
% so that if you begin a paragraph with a \cd{...}, TeX realises you
% are starting a paragraph.
% - Added the codebox env. Tricky bit involving the first line hacked
% with help from David Long.
% Olin 8/94
% Changed the font commands for LaTeX2e.

105
doc/latex/css.t2p
View File

@ -1,105 +0,0 @@
% css.t2p
% Dorai Sitaram
% 19 Jan 2001
% A basic style for HTML documents generated
% with tex2page.
\cssblock
body {
color: black;
background-color: #e5e5e5;
/*background-color: beige;*/
margin-top: 2em;
margin-left: 8%;
margin-right: 8%;
}
h1,h2,h3,h4,h5,h6 {
margin-top: .5em;
}
.partheading {
font-size: 70%;
}
.chapterheading {
font-size: 70%;
}
pre {
margin-left: 2em;
}
ol {
list-style-type: decimal;
}
ol ol {
list-style-type: lower-alpha;
}
ol ol ol {
list-style-type: lower-roman;
}
ol ol ol ol {
list-style-type: upper-alpha;
}
.scheme {
color: brown;
}
.scheme .keyword {
color: #990000;
font-weight: bold;
}
.scheme .builtin {
color: #990000;
}
.scheme .variable {
color: navy;
}
.scheme .global {
color: purple;
}
.scheme .selfeval {
color: green;
}
.scheme .comment {
color: teal;
}
.navigation {
color: red;
text-align: right;
font-style: italic;
}
.disable {
/* color: #e5e5e5; */
color: gray;
}
.smallcaps {
font-size: 75%;
}
.smallprint {
color: gray;
font-size: 75%;
text-align: right;
}
.smallprint hr {
text-align: left;
width: 40%;
}
\endcssblock

6
doc/latex/ct.sty
View File

@ -1,6 +0,0 @@
% Loads cmtt fonts in on \tt. -*- latex -*-
% I prefer these to the Courier fonts that latex gives you w/postscript styles.
% Courier is too spidery and too wide -- it's hard to get 80 chars on a line.
% -Olin
\renewcommand{\ttdefault}{cmtt}

278
doc/latex/decls.tex
View File

@ -1,278 +0,0 @@
\makeatletter
\def\ie{\mbox{\emph{i.e.}}} % \mbox keeps the last period from
\def\Ie{\mbox{\emph{I.e.}}} % looking like an end-of-sentence.
\def\eg{\mbox{\emph{e.g.}}}
\def\Eg{\mbox{\emph{E.g.}}}
\def\etc{{\em etc.}}
\def\Lisp{\textsc{Lisp}}
\def\CommonLisp{\textsc{Common Lisp}}
\def\Ascii{\textsc{Ascii}}
\def\Ansi{\textsc{Ansi}}
\def\Unix{{Unix}} % Not smallcaps, according to Bart.
\def\Scheme{{Scheme}}
\def\scm{{Scheme 48}}
\def\RnRS{R5RS}
\def\Posix{\textsc{Posix}}
\def\sharpf{\textnormal{\texttt{\#f}}}
\def\sharpt{\textnormal{\texttt{\#t}}}
\newcommand{\synteq}{\textnormal{::=}}
\def\maketildeother{\catcode`\~=12}
\def\maketildeactive{\catcode`\~=13}
\def\~{\char`\~}
\newcommand{\evalsto}{\ensuremath{\Rightarrow}}
% One-line code examples
%\newcommand{\codex}[1]% One line, centred. Tight spacing.
% {$$\abovedisplayskip=.75ex plus 1ex minus .5ex%
% \belowdisplayskip=\abovedisplayskip%
% \abovedisplayshortskip=0ex plus .5ex%
% \belowdisplayshortskip=\abovedisplayshortskip%
% \hbox{\ttt #1}$$}
%\newcommand{\codex}[1]{\begin{tightinset}\ex{#1}\end{tightinset}\ignorespaces}
\newcommand{\codex}[1]{\begin{leftinset}\ex{#1}\end{leftinset}\ignorespaces}
\def\widecode{\codeaux{\leftmargin=0pt\topsep=0pt}}
\def\endwidecode{\endcodeaux}
% For multiletter vars in math mode:
\newcommand{\var}[1]{\mbox{\frenchspacing\it{#1}}}
\newcommand{\vari}[2]{\ensuremath{\mbox{\it{#1}}_{#2}}}
%% What you frequently want when you say \tt:
\def\ttchars{\catcode``=13\@noligs\frenchspacing}
\def\ttt{\normalfont\ttfamily\ttchars}
% Works in math mode; all special chars remain special; cheaper than \cd.
% Will not be correct size in super and subscripts, though.
\newcommand{\ex}[1]{{\normalfont\texttt{\ttchars #1}}}
\newenvironment{inset}
{\bgroup\parskip=1ex plus 1ex\begin{list}{}%
{\topsep=0pt\rightmargin\leftmargin}%
\item[]}%
{\end{list}\leavevmode\egroup\global\@ignoretrue}
\newenvironment{leftinset}
{\bgroup\parskip=1ex plus 1ex\begin{list}{}%
{\topsep=0pt}%
\item[]}%
{\end{list}\leavevmode\egroup\global\@ignoretrue}
\newenvironment{tightinset}
{\bgroup\parskip=0pt\begin{list}{}%
{\topsep=0pt\rightmargin\leftmargin}%
\item[]}%
{\end{list}\leavevmode\egroup\global\@ignoretrue}
\newenvironment{tightleftinset}
{\bgroup\parskip=0pt\begin{list}{}%
{\topsep=0pt}%
\item[]}%
{\end{list}\leavevmode\egroup\global\@ignoretrue}
\long\def\remark#1{\bgroup\small\begin{quote}\textsl{Remark: } #1\end{quote}\egroup}
\newenvironment{remarkenv}{\bgroup\small\begin{quote}\textsl{Remark: }}%
{\end{quote}\egroup}
\newcommand{\oops}[1]{\bgroup\small\begin{quote}\textsl{Oops: } #1\end{quote}\egroup}
\newcommand{\note}[1]{\{Note #1\}}
\newcommand{\itum}[1]{\item{\bf #1}\\*}
% For use in code. The \llap magicness makes the lambda exactly as wide as
% the other chars in \tt; the \hskip shifts it right a bit so it doesn't
% crowd the left paren -- which is necessary if \tt is cmtt.
% Note that (\l{x y} (+ x y)) uses the same number of columns in TeX form
% as it produces when typeset. This makes it easy to line up the columns
% in your input. \l is bound to some useless command in LaTeX, so we have to
% define it w/renewcommand.
\let\oldl\l %Save the old \l on \oldl
\renewcommand{\l}[1]{\ \llap{$\lambda$\hskip-.05em}\ (#1)}
% This one is for the rare (lambda x ...) case -- it doesn't have the
% column-invariant property. Oh, well.
\newcommand{\lx}[1]{\ \llap{$\lambda$\hskip-.05em}\ {#1}}
% For subcaptions
\newcommand{\subcaption}[1]
{\unskip\vspace{-2mm}\begin{center}\unskip\em#1\end{center}}
%%% T release notes stuff
\newlength{\notewidth}
\setlength{\notewidth}{\textwidth}
\addtolength{\notewidth}{-1.25in}
%\newcommand{\remark} [1]
% {\par\vspace{\parskip}
% \parbox[t]{.75in}{\sc Remark:}
% \parbox[t]{\notewidth}{\em #1}
% \vspace{\parskip}
% }
\newenvironment{optiontable}%
{\begin{tightinset}\renewcommand{\arraystretch}{1.5}%
\begin{tabular}{@{}>{\ttt}ll@{}}}%
{\end{tabular}\end{tightinset}}%
\newenvironment{desctable}[1]%
{\begin{inset}\renewcommand{\arraystretch}{1.5}%
\begin{tabular}{lp{#1}}}%
{\end{tabular}\end{inset}}
\def\*{{\ttt *}}
% Names of things
\newcommand{\keyword} [1]{\index{#1}{\normalfont\textsf{#1}}}
% \ex{#1} and also generates an index entry.
\newcommand{\exi}[1]{\index{#1@\texttt{#1}}\ex{#1}}
\newcommand{\indextt}[1]{\index{#1@\texttt{#1}}}
\newcommand{\evalto}{$\Longrightarrow$\ }
\renewcommand{\star}{$^*$\/}
\newcommand{\+}{$^+$}
% Semantic domains, used to indicate the type of a value
\newcommand{\sem}{\normalfont\itshape} %semantic font
\newcommand{\semvar}[1]{\textit{#1}} %semantic font
\newcommand{\synvar}[1]{\textrm{\textit{$\left<\right.$#1$\left.\right>$}}} %syntactic font
\newcommand{\type}{\sem}
\newcommand{\zeroormore}[1]{{\sem #1$_1$ \ldots #1$_n$}}
\newcommand{\oneormore}[1]{{\sem #1$_1$ #1$_2$ \ldots #1$_n$}}
\newcommand{\proc} {{\sem procedure}}
\newcommand{\boolean} {{\sem boolean}}
\newcommand{\true} {{\sem true}}
\newcommand{\false} {{\sem false}}
\newcommand{\num} {{\sem number}}
\newcommand{\fixnum} {{\sem fixnum}}
\newcommand{\integer} {{\sem integer}}
\newcommand{\real} {{\sem real}}
\newcommand{\character} {{\sem character}}
\newcommand{\str} {{\sem string}}
\newcommand{\sym} {{\sem symbol}}
\newcommand{\location} {{\sem location}}
\newcommand{\object} {{\sem object}}
\newcommand{\error} {{\sem error}}
\newcommand{\syntaxerror} {{\sem syntax error}}
\newcommand{\readerror} {{\sem read error}}
\newcommand{\undefined} {{\sem undefined}}
\newcommand{\noreturn} {{\sem no return value}}
\newcommand{\port} {{\sem port}}
% semantic variables
\newcommand{\identifier} {{\sem identifier}}
\newcommand{\identifiers} {\zeroormore{\<ident>}}
\newcommand{\expr} {{\sem expression}}
\newcommand{\body} {{\sem body}}
\newcommand{\valueofbody} {{\sem value~of~body}}
\newcommand{\emptylist} {{\sem empty~list}}
\newcommand{\car} {\keyword{car}}
\newcommand{\cdr} {\keyword{cdr}}
\newcommand{\TMPDIR}{\texttt{\$TMPDIR}}
% generally useful things
% For line-breaking \tt stuff.
\renewcommand{\=}{\discretionary{-}{}{-}}
\newcommand{\ob}{\discretionary{}{}{}} % Optional break.
\newcommand{\indx}[1]{#1 \index{ #1 }}
%\newcommand{\gloss}[1]{#1 \glossary{ #1 }}
% This lossage produces #2 if #1 is zero length, otw #3.
% We use it to conditionally add a space between the procedure and
% the args in procedure prototypes, but only if there are any args--
% we want to produce "(read)", not "(read )".
\newlength{\voidlen}
\newcommand{\testvoid}[3]{\settowidth\voidlen{#1}\ifdim\voidlen>0in{#3}\else{#2}\fi}
% Typeset a definition prototype line, e.g.:
% (cons <arg1> <arg2>) -> pair procedure
%
% Five args are: proc-name args ret-value(s) type index-entry
\newcommand{\dfnix}[5]
{\hbox to \linewidth{\ttchars%
{\ttt(#1\testvoid{#2}{}{\ }{\sem{#2}}\testvoid{#2}{}{\/})\hskip 1em minus
0.5em$\longrightarrow$\hskip 1em minus 0.5em{\sem{#3}}\hfill\quad\textnormal{#4}}}\index{#5}}
\newcommand{\dfnx}[4] {\dfnix{#1}{#2}{#3}{#4}{#1@\texttt{#1}}}
\newcommand{\dfn} {\par\medskip\dfnx} % Takes 4 args, actually.
\newcommand{\dfni} {\par\medskip\dfnix} % Takes 5 args, actually.
\newcommand{\defvar} {\par\medskip\defvarx} % Takes 4 args, actually.
\newcommand{\defvarx}[2]%
{\index{#1}
\hbox to \linewidth{\ttchars{{\ttt{#1}} \hfill #2}}}%
% Typeset the protocol line, then do the following descriptive text indented.
% If you want to group two procs together, do the first one with a \dfn,
% then the second one, and the documentation, with a \defndescx.
% This one doesn't put whitespace above. Use it immediately after a \dfn
% to group two prototype lines together.
\newenvironment{dfndescx}[4]%
{\dfnx{#1}{#2}{#3}{#4}\begin{desc}}{\end{desc}}
\newenvironment{dfndesc}[4] % This one puts whitespace above.
{\par\medskip\begin{dfndescx}{#1}{#2}{#3}{#4}}
{\end{dfndescx}}
\newenvironment{desc}%
{\nopagebreak[2]%
\smallskip
\bgroup\begin{list}{}{\topsep=0pt\parskip=0pt}\item[]}
{\end{list}\leavevmode\egroup\global\@ignoretrue}
\def\defun#1#2#3{\dfn{#1}{#2}{#3}{procedure}} % preskip
\newcommand{\defunx}[3]{\dfnx{#1}{#2}{#3}{procedure}} % no skip
\newenvironment{defundescx}[3]%
{\begin{dfndescx}{#1}{#2}{#3}{procedure}}
{\end{dfndescx}}
\newenvironment{defundesc}[3]%
{\begin{dfndesc}{#1}{#2}{#3}{procedure}}
{\end{dfndesc}}
\newenvironment{column}{\begin{tabular}[t]{@{}l@{}}}{\end{tabular}}
\newenvironment{exampletable}%
{\begin{leftinset}%
\newcommand{\header}[1]{\multicolumn{2}{@{}l@{}}{##1}\\}%
\newcommand{\splitline}[2]%
{\multicolumn{2}{@{}l@{}}{##1}\\\multicolumn{2}{@{}l@{}}{\qquad\evalto\quad{##2}}}
\begin{tabular}{@{}l@{\quad\evalto\quad}l@{}}}%
{\end{tabular}\end{leftinset}}
% Put on blank lines in a code env to allow a pagebreak.
\newcommand{\cb}{\pagebreak[0]}
\newenvironment{boxedcode}
{\begin{inset}\tabular{|l|}\hline}
{\\ \hline \end{tabular}\end{inset}}
% A ragged-right decl that doesn't redefine \\ -- for use in tables.
\newcommand{\raggedrightparbox}{\let\temp=\\\raggedright\let\\=\temp}
\newenvironment{boxedfigure}[1]%
{\begin{figure}[#1]\begin{boxedminipage}{\linewidth}\vskip 1.5ex}
{\end{boxedminipage}\end{figure}}
\makeatother

428
doc/latex/dns.tex
View File

@ -1,428 +0,0 @@
\chapter{DNS Client Library}\label{cha:dns}
%
\begin{description}
\item[Used files:] dns.scm
\item[Name of the package:] dns
\end{description}
%
\section{Overview}
The \ex{dns} structure contains a library for querying DNS servers.
Features:
\begin{itemize}
\item Parsing of \texttt{resolv.conf}, including \texttt{search}
entries. This enables looking up the FQDN of a host.
\end{itemize}
\section{Conditions}
The library defines a set of conditions raised by the procedures of
the library. The supertype of these conditions is \exi{dns-error}.
\defun{dns-error?}{thing}{\boolean}
\begin{desc}
The predicate for \ex{dns-error} conditions.
\end{desc}
\defun{dns-error->string} {dns-error-condition} {\str}
\begin{desc}
Returns a string with the description of the condition.
\end{desc}
\defvar{parse-error}{condition}
\defvarx{unexpected-eof-from-server}{condition}
\defvarx{bad-address}{condition}
\defvarx{no-nameservers}{condition}
\defvarx{bad-nameserver}{condition}
\defvarx{not-a-hostname}{condition}
\defvarx{not-a-ip} {condition}
\begin{desc}
\end{desc}
\defvar {dns-format-error} {condition}
\defvarx {dns-server-failure} {condition}
\defvarx {dns-name-error} {condition}
\defvarx {dns-not-implemented} {condition}
\defvarx {dns-refused} {condition}
\begin{desc}
These conditons correspond to errors returned by the DNS server.
They are all subtypes of the \exi{dns-server-error} condition which
in turn is a subtype of \ex{dns-error}.
\end{desc}
\defun{dns-server-error?}{thing}{\boolean}
\begin{desc}
The predicate for \ex{dns-server-error} conditions.
\end{desc}
\defun{parse-error?}{thing} {\boolean}
\defunx{unexpected-eof-from-server?}{thing} {\boolean}
\defunx{bad-address?}{thing} {\boolean}
\defunx{no-nameservers?}{thing} {\boolean}
\defunx{bad-nameserver?}{thing} {\boolean}
\defunx{not-a-hostname?}{thing} {\boolean}
\defunx{not-a-ip?}{thing} {\boolean}
\defunx{dns-format-error?} {thing} {\boolean}
\defunx{dns-server-failure?} {thing} {\boolean}
\defunx{dns-name-error?} {thing} {\boolean}
\defunx{dns-not-implemented?} {thing} {\boolean}
\defunx{dns-refused?} {thing} {\boolean}
\begin{desc}
The type predicates for the conditions above.
\end{desc}
\section{High-level Interface}
\def\ipaddr{\textnormal{IP-address\xspace}}
\def\fqdn{\textnormal{FQDN\xspace}}
The library uses an internal store to cache data obtained from DNS
servers. All procedures take a boolean flag \var{use-cache?} that
indicates whether the cache should be used or not. \var{use-cache?}
defaults to true.
\defun{dns-clear-cache!}{}{\undefined}
\begin{desc}
This procedure erases all information stored in the internal cache.
\end{desc}
The library is further capable of parsing the contents of
\texttt{/etc/resolv.conf} (see Section~\ref{sec:dns-rc}). The
nameservers listed there are the default value for the optional
argument \var{nameserver list} which many procedures of the library
possess.
\defun{dns-lookup-ip}{\fqdn [nameserver list][use-cache?]}{\fqdn}
\begin{desc}
Given the FQDN of a host, \ex{dns-lookup-ip} returns the IP address.
The optional argument specifes the name servers to query, it defaults
to the ones found in \texttt{/etc/resolv.conf}.
\end{desc}
\defun{dns-lookup-ip}{\ipaddr [nameserver list][use-cache?]}{\fqdn}
\begin{desc}
Looks up the FQDN for the given IP address. The optional argument
specifes the name servers to query, it defaults to the ones found in
\texttt{/etc/resolv.conf}. \oops{use-cache? is not implemented yet}
\end{desc}
\defun{dns-lookup-nameserver}{name/\ipaddr [nameserver list][use-cache?]}{\ipaddr list}
\begin{desc}
Looks up an authoritative name server for a hostname, returns a list
of name servers. The optional argument specifes the name servers to
query, it defaults to the ones found in
\texttt{/etc/resolv.conf}\oops{use-cache? is not implemented yet}
\end{desc}
\defun{dns-lookup-mail-exchanger}{name/\ipaddr [nameserver list][use-cache?]}{\fqdn list}
\begin{desc}
Looks up mail-exchangers for a hostname und returns them in a list
sorted by preference. \oops{use-cache? is not implemented yet}
\end{desc}
\defun{socket-address->fqdn}{socket-address [use-cache?]}{\fqdn}
\begin{desc}
Returns the FQDN for of the address bound to argument. The argument
\var{cache?} indicates whether the internal cache may be queried to
obtain the information.\oops{use-cache? is required by the implmentation}
\end{desc}
\defun{maybe-dns-lookup-name}{name [nameserver list][use-cache?]}{\ipaddr or \sharpf}
\defunx{maybe-dns-lookup-ip}{\ipaddr}{\fqdn{} or \sharpf}
\begin{desc}
These procedures provide the same functionality as
\ex{dns-lookup-name} and \ex{dns-lookup-ip} but return \sharpf{} in
case of an \ex{dns-error}.\oops{optional arguments not implemented yet}
\end{desc}
\defun{host-fqdn} {name/socket-address [nameserver list][use-cache?]}{\fqdn}
\defunx{system-fqdn}{[nameserver list][use-cache?]}{\fqdn}
\begin{desc}
\ex{host-fqdn} returns the fully qualified domain name (FQDN) for its
argument which can be either a unqualified host name or a socket
address. The procedure \ex{system-fqdn} returns the FQDN of the
current host.\oops{optional arguments not implemented yet}
\end{desc}
\section{Low-level Interface}
\defun{dns-lookup}{\fqdn/\ipaddr type [nameserver list][use-cache?]}{dns-message}
\begin{desc}
This is the most general way to submit a DNS query. The return value
is a \ex{dns-message} structure:\oops{optional arguments not implemented yet}
\end{desc}
\defun{dns-message?}{thing}{\boolean}
\defunx{dns-message-query}{dns-message}{message}
\defunx{dns-message-reply}{dns-message}{message}
\defunx{dns-message-cache?}{dns-message}{\boolean}
\defunx{dns-message-protocol}{dns-message}{'udp or 'tcp}
\defunx{dns-message-tried-nameservers}{dns-message}{}
\begin{desc}
A \var{dns-message} records the query sent to the server and the
reply from the server. It also contains information whether the
library took the reply from the cache, which protocol was used and
to which nameservers the query was sent.
\end{desc}
\defun{pretty-print-dns-message}{dns-message [output-port]}{\undefined}
\begin{desc}
Pretty prints a DNS message to \var{out-port} which defaults to the
current output port.
\end{desc}
\defun{message?}{thing}{\boolean}{}
\defunx{message-header}{message}{header}
\defunx{message-questions}{message}{question list}
\defunx{message-answers}{message}{rr list}
\defunx{message-nameservers}{message}{rr list}
\defunx{message-additionals}{message}{rr list}
\defunx{message-source}{message}{char list}
\begin{desc}
A \ex{message} represents the data sent to the DNS server or
received from the DNS server. The DNS protocol uses the same message
format for queries and replies. In queries only the header and the
questions is present, a reply may contain answers, name servers and
and additional informations as resource records. \ex{message-source}
returns the actual data sent over the network.
\end{desc}
\defun{header?}{thing}{\boolean}
\defunx{header-id}{header}{number}
\defunx{header-flags}{header}{flags}
\defunx{header-question-count}{header}{number}
\defunx{header-answer-count}{header}{number}
\defunx{header-nameserver-count}{header}{number}
\defunx{header-additional-count}{header}{number}
\begin{desc}
Every DNS message contains a header which stores information about
the data present in the message and contains flags for the query.
\end{desc}
\defun{flags?}{thing}{\boolean}
\defunx{flags-query-type}{flags}{'query or 'response}
\defunx{flags-opcode}{flags}{number}
\defunx{flags-authoritative?}{flags}{\boolean}
\defunx{flags-truncated?}{flags}{\boolean}
\defunx{flags-recursion-desired?}{flags}{\boolean}
\defunx{flags-recursion-available?}{flags}{\boolean}
\defunx{flags-z}{flags}{0}
\defunx{flags-response-code}{flags}{number}
\begin{desc}
Flags occur within the header of a DNS message. The boolean value
returned from \ex{flags-authoritative} indicates whether the message
was sent from a authoritative server, \ex{flags-truncated?} should
always be \sharpf as the library automatically uses the TCP protocol
is the UDP message size is not sufficied.
\end{desc}
\defun{question?}{thing}{\boolean}
\defunx{question-name}{question}{\str}
\defunx{question-type}{question}{message-type}
\defunx{question-class}{question}{message-class}
\begin{desc}
A question sent to the DNS server.
\end{desc}
The type and class of the question and answer are elements of
enumerated types: \textbf{class doesn't start at 0}
\dfn{message-class}{class-name}{message-class}{syntax}
\defunx{message-class?}{thing}{\boolean}
\defunx{message-class-name}{message-class}{symbol}
\defunx{message-class-number}{message-class}{number}
\begin{desc}
\ex{message-class} constructs a member of the enumeration,
\ex{message-class?} is the type predicate, \ex{message-class-name}
returns the symbol and \ex{message-class-number} the number used for
the class in the DNS protocol.
\end{desc}
The possible names for the classes are:
\begin{description}
\item[\ex{in}] The Internet
\item[\ex{cs}] obsolete
\item[\ex{ch}] the CHAOS class
\item[\ex{hs}] Hesoid
\end{description}
\dfn{message-type}{type-name}{message-type}{syntax}
\defunx{message-type?}{thing}{\boolean}
\defunx{message-type-name}{message-type}{symbol}
\defunx{message-type-index}{message-type}{number}
\begin{desc}
\ex{message-type} constructs a member of the enumeration from name
\synvar{type-name} listed in Table~\ref{tab:message-types}.
\ex{message-type?} is the type predicate, \ex{message-type-name}
returns the name, and \ex{message-type-number} the number used for
the class the DNS protocol.
\end{desc}
\begin{table}[htb]
\centering
\begin{tabular}{|l|l|}
\hline
\ex{a}& a host address\\\hline
\ex{ns}&an authoritative name server\\\hline
\ex{md}&(obsolete)\\\hline
\ex{mf}&(obsolete)\\\hline
\ex{cname}&the canonical name for an alias\\\hline
\ex{soa}& marks the start of a zone of authority\\\hline
\ex{mb}&(experimental)\\\hline
\ex{mg}&(experimental)\\\hline
\ex{mr}&(experimental)\\\hline
\ex{null}& (experimental)\\\hline
\ex{wks}& a well known service description\\\hline
\ex{ptr}& a domain name pointer\\\hline
\ex{hinfo}& host information\\\hline
\ex{minfo}& (experimental)\\\hline
\ex{mx}& mail exchange\\\hline
\ex{txt}& text strings\\\hline
\end{tabular}
\caption{Message types}
\label{tab:message-types}
\end{table}
\defun{rr?}{thing}{\boolean}
\defunx{rr-name}{rr}{\str}
\defunx{rr-type}{rr}{message-type}
\defunx{rr-class}{rr}{message-class}
\defunx{rr-ttl}{rr}{number}
\defunx{rr-data}{rr}{rr-data-X}
\begin{desc}
A resource record as returned from the DNS server. The actual data
of the record is stored in the \texttt{rr-data} field.
\end{desc}
\defun{rr-data-a?}{thing}{\boolean}
\defunx{rr-data-a-ip}{rr-data-a}{\ipaddr}
\begin{desc}
An address resource record which holds an internet address.
\end{desc}
\defun{rr-data-ns?}{thing}{\boolean}
\defunx{rr-data-ns-name}{rr-data-ns}{\fqdn}
\begin{desc}
A name server resource record containing the FQDN of the name server.
\end{desc}
\defun{rr-data-cname?}{thing}{\boolean}
\defunx{rr-data-cname}{rr-data-cname}{\fqdn}
\begin{desc}
A canonical name resource record which contains the canonical or
primary name of the owner.
\end{desc}
\defun{rr-data-mx?}{thing}{\boolean}
\defunx{rr-data-mx-preference}{rr-data-mx}{number}
\defunx{rr-data-mx-exchanger}{rr-data-mx}{\fqdn}
\begin{desc}
A mail exchange resource record with the preference and the FQDN of
a host willing to act as a mail exchange.
\end{desc}
\defun{rr-data-ptr?}{thing}{\boolean}
\defunx{rr-data-ptr-name}{rr-data-ptr}{\str}
\begin{desc}
A pointer resource record which points to some other domain name.
\end{desc}
\defun{rr-data-soa?}{thing}{\boolean}
\defunx{rr-data-soa-mname}{rr-data-soa}{\fqdn}
\defunx{rr-data-soa-rname}{rr-data-soa}{\fqdn}
\defunx{rr-data-soa-serial}{rr-data-soa}{number}
\defunx{rr-data-soa-refresh}{rr-data-soa}{number}
\defunx{rr-data-soa-retry}{rr-data-soa}{number}
\defunx{rr-data-soa-expire}{rr-data-soa}{number}
\defunx{rr-data-soa-minimum}{rr-data-soa}{number}
\begin{desc}
A zone of authority resource record.
\end{desc}
The protocol specifies other possiple values for the \texttt{rr-data}
field but we where no able to find test cases for them.
\defun{cache?}{thing}{\boolean}
\defunx{cache-answer}{cache}{dns-message}
\defunx{cache-ttl}{cache}{number}
\defunx{cache-time}{cache}{number}
\begin{desc}
A cache data structure corresponds to a saved answer to a previous
query. \ex{cache-answer} returns the saved message, \ex{cache-ttl}
returns the time when the cache entry expires and \ex{cache-time}
returns the time the entry was created.
\end{desc}
\section{Host Names}
\defun{is-fqdn?}{\str}{\boolean}
\begin{desc}
Indicates whether the argument matches the grammar for a fully
qualified domain name.
\oops{The current implementation simply searches for a dot in the name}
\end{desc}
\defun{unqualified-hostname?}{\str}{\boolean}
\begin{desc}
Returns true if the argument matches the grammar for a unqualified
host name.
\oops{This procedure isn't implemented yet}
\end{desc}
\section{Parsing \texttt{/etc/resolv.conf}}
\label{sec:dns-rc}
\defvar{resolv.conf-parse-error} {condition}
\defun{resolv.conf-parse-error?}{thing}{\boolean}
\begin{desc}
The code signals the condition \var{resolv.conf-parse-error} if a
parse error occurs while scanning \texttt{/etc/resolv.conf}. It is a
subtype of the \var{dns-error} condition.
\ex{resolv.conf-parse-error?} is the type predicate for this
condition.
\oops{this is not implemented yet}
\end{desc}
\defun{resolv.conf}{}{{symbol$\rightarrow$string} alist}
\begin{desc}
Returns the contents of \texttt{/etc/resolv.conv} as an alist with
the possible keys \texttt{nameserver}, \texttt{domain},
\texttt{search}, \texttt{sortlist}, \texttt{options}.
Note that the library caches the contents of
\texttt{/etc/resolv.conv} and \ex{resolv.conf} only really opens the
file if its modification time is more recent than the modification
time of the cache.
\end{desc}
\defun{parse-resolv.conf!}{}{\undefined}
\begin{desc}
Parses the contents of \texttt{/etc/resolv.conv} and updates the
internal cache of the library.
\end{desc}
\defun{dns-find-nameserver-list}{}{\fqdn list}
\begin{desc}
Returns a list of name servers from \texttt{/etc/resolv.conf}
\end{desc}
\defun{dns-find-nameserver}{}{\fqdn}
\begin{desc}
Returns the first name servers found in \texttt{/etc/resolv.conf}.
\ex{dns-find-nameserver} raises \ex{no-nameservers} if
\texttt{/etc/resolv.conf} does not contain a \texttt{nameserver}
entry.
\end{desc}
\defun{domains-for-search}{}{\str list}
\begin{desc}
Parses \texttt{/etc/resolv.conf} and extracts the domains specified
by the \texttt{search} keyword.
\end{desc}
\section{IP Addresses as Dotted Strings}
\textbf{Should live in its own package}
\defun{address32->ip-string}{\ipaddr}{ip-string}
\defun{ip-string->address32}{ip-string}{\ipaddr}
\defun{ip-string?}{string}{\boolean}
\begin{desc}
Tests whether \var{string} represents a valid IPv4 address.
\oops{not yet implemented}
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

163
doc/latex/ftp.tex
View File

@ -1,163 +0,0 @@
\chapter{FTP Client}\label{cha:ftp}
The \ex{ftp} structure lets you transfer files between networked
machines from the Scheme Shell, using the File Transfer Protocol as
described in RFC~959.
Some of the procedures in this module extract useful information from
the server's reply, such as the size of a file, or the name of the
directory we have moved to. These procedures return the extracted
information, or, if the server's response doesn't match the expected
code from the server, a catchable \ex{ftp-error} is raised.
\defun{ftp-connect}{host login password passive? [log-port]}{connection}
\begin{desc}
Open a command connection with the remote machine \var{host} and
login on that server with \var{login} and \var{password}.
\var{Login} and \var{password} can be \sharpf, in which case the
information is extracted from the user's \ex{.netrc} file if necessary.
If \var{log-port} is specified, it must be an output port: this
starts logging the conversation with the server to that port. Note
that the log contains passwords in clear text.
\end{desc}
\dfn{ftp-type}{\synvar{name}}{ftp-type}{syntax}
\defunx{set-ftp-type!}{connection ftp-type}{undefined}
\begin{desc}
This change the transfer mode for future file transfers. The
transfer mode is specfified by \var{ftp-type} which can be created
with the \ex{ftp-type} macro. \synvar{Name} must be either
\ex{binary} for binary data or \ex{ascii} for text.
\end{desc}
\defun{ftp-rename}{connection old new}{undefined}
\begin{desc}
This changes the name of \var{old} on the remote host to \var{new}
(assuming sufficient permissions). \var{Old} and \var{new} are
strings.
\end{desc}
\defun{ftp-delete}{connection file}{undefined}
\begin{desc}
This deletes \var{file} from the remote host (assuming the user has
appropriate permissions).
\end{desc}
\defun{ftp-cd}{connection dir}{undefined}
\begin{desc}
This changes the current directory on the server.
\end{desc}
\defun{ftp-cdup}{connection}{undefined}
\begin{desc}
This move to the parent directory on the server.
\end{desc}
\defun{ftp-pwd}{connection}{string}
\begin{desc}
Return the current directory on the remote host, as a string.
\end{desc}
\defun{ftp-ls}{connection [dir]}{list}
\begin{desc}
This returns a list of filenames on the remote host, either from the
current directory (if \var{dir} is not specified), or from the
directory specified by \var{dir}.
\end{desc}
\defun{ftp-dir}{connection [dir]}{status}
\begin{desc}
This returns a list of long-form file name entries on the remote
host, either from the current directory (if \var{dir} is not
specified), or from the directory specified by \var{dir}. (Note
that the format for the long-form entries is not specified by the
FTP standard.)
\end{desc}
\defun{ftp-get}{connection remote-file proc}{undefined}
\begin{desc}
This downloads \var{remote-file} from the FTP server.
\ex{Ftp-get} establishes a data conneciton to the server, attaches
an input port to the data connection, and calls \var{proc} on that
port.
\end{desc}
\defun{ftp-put}{connection remote-file proc}{undefined}
\begin{desc}
This uploads \var{remote-file} to the FTP server. \ex{Ftp-put}
establishes a data conneciton to the server, attaches an output port
to the data connection, and calls \var{proc} on that port.
\end{desc}
\defun{ftp-append}{connection remote-file proc}{undefined}
\begin{desc}
This appends data to \var{remote-file} on the FTP server.
\ex{Ftp-append} establishes a data conneciton to the server,
attaches an output port to the data connection, and calls \var{proc}
on that port.
\end{desc}
\defun{ftp-rmdir}{connection dir}{undefined}
\begin{desc}
This removes the directory \var{dir} from the remote host (assuming
sufficient permissions).
\end{desc}
\defun{ftp-mkdir}{connection dir}{undefined}
\begin{desc}
This create a new directory named \var{dir} on the remote host
(assuming sufficient permissions).
\end{desc}
\defun{ftp-modification-time}{connection file}{date}
\begin{desc}
This requests the time of the last modification of \var{file} on the
remote host, and on success return a Scsh date record. (This command
is not part of RFC~959 and is not implemented by all servers, but is
useful for mirroring.)
\end{desc}
\defun{ftp-size}{connection file}{integer}
\begin{desc}
This returns the size of \var{file} in bytes. (This command is not
part of RFC~959 and is not implemented by all servers.)
\end{desc}
\defun{ftp-quit}{connection}{undefined}
\begin{desc}
This closes the connection to the remote host. The \var{connection}
object is useless after a quit command.
\end{desc}
\defun{ftp-quot}{connection command}{status}
\begin{desc}
This sends a \var{command} verbatim to the remote server and wait
for a response. The response text is returned verbatim.
\end{desc}
\defun{ftp-error?}{thing}{boolean}
\begin{desc}
This returns \sharpt{} if \var{thing} is a \ex{ftp-error} object,
otherwise \sharpf.
\end{desc}
\defun{copy-port->port-binary}{input-port oputput-port}{undefined}
\defunx{copy-port->port-ascii}{input-port oputput-port}{undefined}
\defunx{copy-ascii-port->port}{input-port oputput-port}{undefined}
\begin{desc}
These procedures are useful for downloading and uploading data to an
FTP connection via \ex{ftp-get}, \ex{ftp-get}, and \ex{ftp-append}.
They all copy data from one port to another.
\ex{Copy-port->port-binary} copies verbatim, while the other two
perform CR/LF conversion for ASCII data transfers.
\ex{Copy-port->port-ascii} adds CR/LFs at line endings on output,
whereas \ex{Copy-ascii-port->port} removes CR/LFs at line endings
end replaces them by ordinary LFs.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

203
doc/latex/ftpd.tex
View File

@ -1,203 +0,0 @@
\chapter{FTP server}\label{cha:ftpd}
\begin{description}
\item[Used files:] ftpd.scm
\item[Name of the package:] ftpd
\end{description}
\section{What users want to know}
\section{Entry points}
\defun {ftpd} {options} {\noreturn}
\begin{defundescx}{ftp-inetd} {anonymous-home} {\noreturn}
\ex{ftpd} starts the server, using \semvar{anonymous-home} as the
root directory of the server. Usage of relative paths is not
encouraged. \semvar{port} specifies the port the server is
listening for connections. It defaults to 21. \ex{ftpd} makes a log
entry for each file sent or retrieved. These logs are written to
\semvar{logfile}, if given. If \semvar{dns-lookup?} is \sharpt, the
logfile will contain the host names instead of their IP
addresses. If \semvar{dns-lookup?} is not specified or \sharpf, the
IP addresses are stored.
The log format of \ex{ftpd} is the same as the one of
\ex{wuftpd}. The fields are seperated by spaces and contain
following informations:
\codex{Fri Apr 19 17:08:14 2002 4 134.2.2.171 56881 /files.lst b \_ i a nop@ssword ftp 0 *}
\begin{enumerate}
\item Current date and time. This field contains
spaces and is 24 characters long.
\item Transfer time in seconds.
\item Remote host IP (wuftpd puts the name here).
\item File size in bytes
\item Name of file (spaces are converted to underscores)
\item Transfer type: \underline{a}scii or \underline{b}inary (image type).
\item Special action flags. As \ex{ftpd} does not support any special
action, we are always `\ex{\_}' here.
\item File was sent to user (\underline{o}utgoing) or received from user
(\underline{i}ncoming)
\item \underline{A}nonymous access
\item Anonymous ftp password. We do not use anyone.
\item Service name - always \ex{ftp}.
\item Authentication mode (always none = `\ex{0}').
\item Authenticated user ID (always not available = `\ex{*}')
\end{enumerate}
As the procedure does not return, you have to do a \ex{fork} in
order to have a ``real'' daemon: \codex{(fork (lambda () (ftpd
"/data/ftp" 8080)))} \ex{ftpd-inetd} is the version to be used with
a daemon like \ex{inetd}. If the server is started this way, it
handles the connection through the current standard output and input
ports.
\end{defundescx}
\subsubsection*{Examples}
To start the server with the current home directory as root directory
and listening on port 8080, use
\codex{(ftpd (cwd) 8080)}
This is how the ftp server at the computing faculty of the university
of Tuebingen\footnote{\texttt{archive.informatik.uni-tuebingen.de}} is
started:
\begin{alltt}
#!/bin/sh /scsh-0.6-alpha/bin/scsh <<EOF
,batch on
,config ,load modules.scm
,open ftpd
,open threads
(define (archive-ftpd args)
(with-syslog-destination
#f
#f
(syslog-facility local0)
#f
(lambda ()
(ftpd "/data/archive/"))))
(dump-scsh-program archive-ftpd "archive-ftpd.image")
;; (dump-scsh "archive-ftpd.image")
EOF
\end{alltt}
Perhaps you have noticed the \ex{with-syslog-destination} command.
\ex{ftpd} generates syslog-messages that can be controlled via this
command. The following section gives you an overview of what is logged
at which level. See \ex{man 3 syslog} or the
\ex{with-syslog-destination} command in the scsh-manual for further
details.
\subsubsection*{Syslog messages}
\ex{ftpd} outputs a lot of syslog-messages. A syslog-message may look like
this:
\codex{Jul 24 18:34:52 axl ftpd: (thread 21) anonymous user login (230)}
The log gives you following informations (including those delivered by
the syslog-daemon):
\begin{enumerate}
\item The date and time the log was made (here: Jul 24 18:34:52)
\item The machine the log was made on (here: axl)
\item The program, that output the log (ftpd)
\item The thread the message concerns (here thread 21)
Each connection is linked with a thread, that handles the commands
of this connection. When the thread is created, there is a entry in
the log file containing the remote address and the thread number, so
in future logs the thread number labels the connection. As at any
given time the thread number is unique, this is a bijection. (Note
that the thread numbers are not unique over a period of time).
\item The log message (here: notification about an anonymous user login)
\item The reply code returned by ftpd, if any (here: 230)
\end{enumerate}
\subsubsection*{The Syslog-levels used\footnote{For further details
on syslog levels see \ex{man 3 syslog}}}
Following events are logged as
\begin{description}
\item[\ex{NOTICE} level:]
\begin{itemize}
\item Messages concerning \emph{connections} (establishing connection,
connection refused, closing connection due to timeout, etc.)
\item The execution of the \ex{STOR} command. Its success (\ie
somebody is putting something on your server via ftp, also known as
\ex{PUT}) is also logged at notice-level. In fact, the log is made
before the storing is started actually.
\item Internal errors
\item Unix errors
\item Reaching of actually unreachable case branches
\end{itemize}
\item[\ex{INFO} level:] Messages concerning all \emph{other commands},
including the \ex{RETR} command.
\item[\ex{DEBUG} level:] All other messages, including debug messages.
If you want to debug ftpd, put all the messages in one single file,
since the debug-messages may refer to messages of other levels.
\end{description}
Success (as long as interesting) and failure of commands are logged at
info-level, except the success of the STOR-command, that is logged at
notice-level (as mentioned above).
\subsubsection*{Supported commands}
For those of you who are intrested, the table \ref{ftpd-commands}
shows the list of supported commands by \ex{ftpd} according to
RFC~959:
%{Can there be a pagebreak in a table?}
\begin{table}
\label{ftpd-commands}
\begin{center}
\begin{tabular}{|lp{10cm}|}
\hline
\ex{ABOR} & abort connection \\
\ex{CDUP} & move to parent directory \\
\ex{CWD} & move to specified directory (relative paths may be used) \\
\ex{DELE} & delete file \\
\ex{LIST} & list files in current directory (long format) \\
\ex{MDTM} & deliver modification time of a regular file \\
\ex{MKD} & make directory \\
\ex{MODE} & change mode (only stream mode (S) is supported) \\
\ex{NLST} & list files in current directory (short format) \\
\ex{NOOP} & do nothing \\
\ex{PASS} & read in passphrase (\ex{ftpd} currently does not support
non-anonymous logins) \\
\ex{PASV} & change to passive mode \\
\ex{PORT} & change connection port \\
\ex{PWD} & return name of working directory (print working directory) \\
\ex{QUIT} & quit session \\
\ex{RETR} & return file (GET) \\
\ex{RMD} & remove directory \\
\ex{RNFR} & read in the name of a file to be renamed (use \ex{RNTO} next) \\
\ex{RNTO} & rename file mentioned before in a \ex{RNFR} command \\
\ex{SIZE} & return size of a regular file \\
\ex{STOR} & store file (PUT) \\
\ex{STRU}& change structure to transfer files
(only the file structure is supported) \\
\ex{SYST} & return system type \\
\ex{TYPE} & change type (supported types: A is ascii mode,
I or L8 are 8-bit binary mode) \\
\ex{USER} & login user (only anonymous logins allowed,
use ``anonymous'' or ``ftp'' as user name) \\
\hline
\end{tabular}
\caption{Supported RFC~959 commands by the server.}
\end{center}
\end{table}
%\subsection{What programmers want to know}
%Let me know what you want to know. As long as you are waiting for my
%answer, have a look in the source file (I'm sorry).
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

16
doc/latex/headings.sty
View File

@ -1,16 +0,0 @@
% headings.tex -*- latex -*-
% Quieter headings that the ones used in article.sty.
% This is not a style option. Don't say [headings].
% Instead, say \input{headings} after the \documentstyle.
% -Olin 7/91
\makeatletter
\def\section{\@startsection {section}{1}{\z@}{-3.5ex plus -1ex minus
-.2ex}{2.3ex plus .2ex}{\large\normalfont\bfseries}}
\def\subsection{\@startsection{subsection}{2}{\z@}{-3.25ex plus -1ex minus
-.2ex}{1.5ex plus .2ex}{\normalsize\normalfont\bfseries}}
\def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-3.25ex plus
-1ex minus -.2ex}{1.5ex plus .2ex}{\normalsize\normalfont\bfseries}}
\makeatother

649
doc/latex/httpd.tex
View File

@ -1,649 +0,0 @@
\chapter{HTTP server}\label{cha:httpd}
%
The SUnet HTTP Server is a complete industrial-strength implementation
of the HTTP 1.0 protocol. It is highly configurable and allows the writing
of dynamic web pages that run inside the server without going through
complicated and slow protocols like CGI or Fast/CGI.
\section{Starting and configuring the server}
All procedures described in this section are exported by the
\texttt{httpd} structure.
The Web server is started by calling the \ex{httpd} procedure, which takes
one argument, an options value:
\defun{httpd}{options}{\noreturn}
\begin{desc}
This procedure starts the server. The \var{options} argument
specifies various configuration parameters, explained below.
The server's basic loop is to wait on the port for a connection from
an HTTP client. When it receives a connection, it reads in and
parses the request into a special request data structure. Then the
server forks a thread which binds the current I/O ports to the
connection socket, and then hands off to the top-level
request handler (which must be specified in the options). The
request handler is responsible for actually serving
the request---it can be any arbitrary computation. Its output goes
directly back to the HTTP client that sent the request.
Before calling the request handler to service the request, the HTTP
server installs an error handler that fields any uncaught error,
sends an error reply to the client, and aborts the request
transaction. Hence any error caused by a request handler will be
handled in a reasonable and robust fashion.
\end{desc}
%
The options argument can be constructed through a number of procedures
with names of the form \texttt{with-\ldots}. Each of these procedures
either creates a fresh options value or adds a configuration parameter
to an old options argument. The configuration parameter value is
always the first argument, the (old) options value the optional second
one. Here they are:
\defun{with-port}{port [options]}{options}
\begin{desc}
This specifies the port on which the server listens. Defaults to 80.
\end{desc}
\defun{with-root-directory}{root-directory [options]}{options}
\begin{desc}
This specifies the current directory of the server. Note that this
is \emph{not} the document root directory. Defaults to \texttt{/}.
\end{desc}
\defun{with-fqdn}{fqdn [options]}{options}
\begin{desc}
This specifies the fully-qualified domain name the server uses in
automatically generated replies, or \ex{\#f} if the server should
query DNS for the fully-qualified domain name.. Defaults to \ex{\#f}.
\end{desc}
\defun{with-reported-port}{reported-port [options]}{options}
\begin{desc}
This specifies the port number the server uses in automatically
generated replies or \ex{\#f} if the reported port is the same as
the port the server is listening on. (This is useful if you're
running the server through an accelerating proxy.) Defaults to
\ex{\#f}.
\end{desc}
\defun{with-server-admin}{mail-address [options]}{options}
\begin{desc}
This specifies the email address of the server administrator the
server uses in automatically generated replies. Defaults to \ex{\#f}.
\end{desc}
\defun{with-icon-name}{icon-name [options]}{options}
\begin{desc}
This specifies how to generate the links to various decorative icons
for the listings. It can either be a procedure which gets passed an
icon tag (a symbol) and is expected to return a link pointing to the icon. If
it is a string, that is taken as prefix to which the icon tag are
appended. If \ex{\#f}, just the plain file names will be used. Defaults to \ex{\#f}.
The valid icon tags, together with the default names of their icon
files, are:
\begin{center}
\begin{tabular}{|l|l|}
\hline
\texttt{directory} & \texttt{directory.xbm}\\\hline
\texttt{text} & \texttt{text.xbm}\\\hline
\texttt{doc} & \texttt{doc.xbm}\\\hline
\texttt{image} & \texttt{image.xbm}\\\hline
\texttt{movie} & \texttt{movie.xbm}\\\hline
\texttt{audio} & \texttt{sound.xbm}\\\hline
\texttt{archive} & \texttt{tar.xbm}\\\hline
\texttt{compressed} & \texttt{compressed.xbm}\\\hline
\texttt{uu} & \texttt{uu.xbm}\\\hline
\texttt{binhex} & \texttt{binhex.xbm}\\\hline
\texttt{binary} & \texttt{binary.xbm}\\\hline
\texttt{blank} & \texttt{blank.xbm}\\\hline
\texttt{back} & \texttt{back.xbm}\\\hline
unknown & \texttt{unknown.xbm}\\\hline
\end{tabular}
Example icons can be found as part of the CERN httpd distribution
at \url{http://www.w3.org/pub/WWW/Daemon/}.
\end{center}
\end{desc}
\defun{with-request-handler}{request-handler [options]}{options}
\begin{desc}
This specifies the request handler of the server to which the server
delegates the actual work. More on that subject below in
Section~\ref{httpd:request-handlers}. This parameter must be specified.
\end{desc}
\defun{with-simultaneous-requests}{requests [options]}{options}
\begin{desc}
This specifies a limit on the number of simultaneous requests the
server servers. If that limit is exceeded during operation, the
server will hold off on new requests until the number of
simultaneous requests has sunk below the limit again. If this
parameter is \ex{\#f}, no limit is imposed. Defaults to \ex{\#f}.
\end{desc}
\defun{with-logfile}{logfile [options]}{options}
\begin{desc}
This specifies the name of a log file for the server where it writes
Common Log Format logging information. It can also be a port in
which case the information is logged to that port, or \ex{\#f} for
no logging. Defaults to \ex{\#f}.
To allow rotation of logfiles, the server re-opens the logfile
whenever it receives a \texttt{USR1} signal.
\end{desc}
\defun{with-syslog?}{syslog? [options]}{options}
\begin{desc}
This specifies whether the server will log information about
incoming to the Unix syslog facility. Defaults to \ex{\#t}.
\end{desc}
\defun{with-resolve-ip?}{resolve-ip? [options]}{options}
\begin{desc}
This specifies whether the server writes the domain names rather
than numerical IPs to the output log it produces. Defaults to
\ex{\#t}.
\end{desc}
To avoid paranthitis, the \ex{make-httpd-options} procedure eases the
construction of the options argument:
\defun{make-httpd-options}{transformer value \ldots}{options}
\begin{desc}
This constructs an options value from an argument list of parameter
transformers and parameter values. The arguments come in pairs,
each an option transformer from the list above, and a value for that
parameter. \ex{Make-httpd-options} returns the resulting options value.
\end{desc}
For example,
\begin{alltt}
(httpd (make-httpd-options
with-request-handler (rooted-file-handler "/usr/local/etc/httpd")
with-root-directory "/usr/local/etc/httpd"))
\end{alltt}
%
starts the server on port 80 with
\ex{/usr/local/etc/httpd} as its root directory and
lets it serve any file out from this directory.
% #### note about rooted-file-handler
\section{Requests}
\label{httpd:requests}
Request handlers operate on \textit{requests} which contain the
information needed to generate a page. The relevant procedures to
dissect requests are defined in the \texttt{httpd-requests} structure:
\defun{request?}{value}{boolean}
\defunx{request-method}{request}{string}
\defunx{request-uri}{request}{string}
\defunx{request-url}{request}{url}
\defunx{request-version}{request}{pair}
\defunx{request-headers}{request}{list}
\defunx{request-socket}{request}{socket}
\begin{desc}
The procedure inspect request values. \ex{Request?} is a predicate
for requests. \ex{Request-method} extracts the method of the HTTP
request; it's a string such as \verb|"GET"|, \verb|"PUT"|.
\ex{Request-uri} returns the escaped URI string as read from request
line. \ex{Request-url} returns an HTTP URL value (see the
description of the \ex{url} structure in \ref{cha:url}).
\ex{Request-version} returns \verb|(major . minor)| integer pair
representing the version specified in the HTTP request.
\ex{Request-headers} returns an association lists of header field
names and their values, each represented by a list of strings, one
for each line. \ex{Request-socket} returns the the socket connected
to the client.\footnote{Request handlers should not perform I/O on the
request record's socket. Request handlers are frequently called
recursively, and doing I/O directly to the socket might bypass a
filtering or other processing step interposed on the current I/O ports
by some superior request handler.}
\end{desc}
\section{Responses}
\label{sec:http-responses}
A path handler must return a \textit{response} value representing the
content to be sent to the client. The machinery presented here for
constructing responses lives in the \ex{httpd-responses} structure.
\defun{make-response}{status-code maybe-message seconds mime extras
body}{response}
\begin{desc}
This procedure constructs a response value. \var{Status-code} is an
HTTP status code (more on that below). \var{Maybe-message} is a a
message elaborating on the circumstances of the status code; it can
also be \sharpf{} meaning that the server should send a default
message associated with the status code. \var{Seconds} natural
number indicating the time the content was created, typically the
value of \verb|(time)|. \var{Mime} is a string indicating the MIME
type of the response (such as \verb|"text/html"| or
\verb|"application/octet-stream"|). \var{Extras} is an association
list with extra headers to be added to the response; its elements
are pairs, each of which consists of a symbol representing the field
name and a string representing the field value. \var{Body}
represents the body of the response; more on that below.
\end{desc}
\defun{make-redirect-response}{location}{response}
\begin{desc}
This is a helper procedure for constructing HTTP redirections. The
server will serve the new file indicated by \var{location}.
\var{Location} must be URI-encoded and begin with a slash.
\end{desc}
\defun{make-error-response}{status-code request [message] extras \ldots}{response}
\begin{desc}
This is a helper procedure for constructing error responses.
\var{code} is status code of the response (see below). \var{Request}
is the request that led to the error. \var{Message} is an optional
string containing an error message written in HTML, and \var{extras}
are further optional arguments containing further message lines to
be added to the web page that's generated.
\ex{Make-error-response} constructs a response value which generates
a web page containg a short explanatory message for the error at hand.
\end{desc}
\begin{table}[htb]
\centering
\begin{tabular}{|l|l|l|}
\hline
ok & 200 & OK\\\hline
created & 201 & Created\\\hline
accepted & 202 & Accepted\\\hline
prov-info & 203 & Provisional Information\\\hline
no-content & 204 & No Content\\\hline
mult-choice & 300 & Multiple Choices\\\hline
moved-perm & 301 & Moved Permanently\\\hline
moved-temp & 302 & Moved Temporarily\\\hline
method & 303 & Method (obsolete)\\\hline
not-mod & 304 & Not Modified\\\hline
bad-request & 400 & Bad Request\\\hline
unauthorized & 401 & Unauthorized\\\hline
payment-req & 402 & Payment Required\\\hline
forbidden & 403 & Forbidden\\\hline
not-found & 404 & Not Found\\\hline
method-not-allowed & 405 & Method Not Allowed\\\hline
none-acceptable & 406 & None Acceptable\\\hline
proxy-auth-required & 407 & Proxy Authentication Required\\\hline
timeout & 408 & Request Timeout\\\hline
conflict & 409 & Conflict\\\hline
gone & 410 & Gone\\\hline
internal-error & 500 & Internal Server Error\\\hline
not-implemented & 501 & Not Implemented\\\hline
bad-gateway & 502 & Bad Gateway\\\hline
service-unavailable & 503 & Service Unavailable\\\hline
gateway-timeout & 504 & Gateway Timeout\\\hline
\end{tabular}
\caption{HTTP status codes}
\label{tab:status-code-names}
\end{table}
\dfn{status-code}{\synvar{name}}{status-code}{syntax}
\defunx{name->status-code}{symbol}{status-code}
\defunx{status-code-number}{status-code}{integer}
\defunx{status-code-message}{status-code}{string}
\begin{desc}
The \ex{status-code} syntax returns a status code where
\synvar{name} is the name from Table~\ref{tab:status-code-names}.
\ex{Name->status-code} also returns a status code for a name
represented as a symbol. For a given status code,
\ex{status-code-number} extracts its number, and
\ex{status-code-message} extracts its associated default message.
\end{desc}
\section{Response Bodies}
\label{httpd:response-bodies}
A \textit{response body} represents the body of an HTTP response.
There are several types of response bodies, depending on the
requirements on content generation.
\defun{make-writer-body}{proc}{body}
\begin{desc}
This constructs a response body from a \textit{writer}---a procedure
that prints the page contents to a port. The \var{proc} argument
must be a procedure accepting an output port (to which \var{proc}
prints the body) and the options value passed to the \ex{httpd}
invocation.
\end{desc}
\defun{make-reader-writer-body}{proc}{body}
\begin{desc}
This constructs a response body from a \textit{reader/writer}---a
procedure that prints the page contents to a port, possibly after
reading input from the socket of the HTTP connection. The
\var{proc} argument must be a procedure accepting three arguments:
an input port (associated with the HTTP connection socket), an
output port (to which \var{proc} prints the body), and the options
value passed to the \ex{httpd} invocation.
\end{desc}
\section{Request Handlers}
\label{httpd:request-handlers}
A request handler generates the actual content for a request; request
handlers form a simple algebra and may be combined and composed in
various ways.
A request handler is a procedure of two arguments like this:
\defun{request-handler}{path req}{response}
\begin{desc}
\var{Req} is a request. The \semvar{path} argument is the URL's
path, parsed and split at slashes into a string list. For example,
if the Web client dereferences URL
%
\begin{verbatim}
http://clark.lcs.mit.edu:8001/h/shivers/code/web.tar.gz
\end{verbatim}
then the server would pass the following path to the top-level
handler:
%
\begin{verbatim}
("h" "shivers" "code" "web.tar.gz")
\end{verbatim}
%
The \var{path} argument's pre-parsed representation as a string
list makes it easy for the request handler to implement recursive
operations dispatch on URL paths.
The request handler must return an HTTP response.
\end{desc}
\subsection{Basic Request Handlers}
The web server comes with a useful toolbox of basic request handlers
that can be used and built upon. The following procedures are
exported by the \ex{httpd\=basic\=handlers} structure:
\defvar{null-request-handler}{request-handler}
\begin{desc}
This request handler always generated a \ex{not-found} error
response, no patter what the request is.
\end{desc}
\defun{make-predicate-handler}{predicate handler
default-handler}{request-handler}
\begin{desc}
The request handler returned by this procedure first calls
\var{predicate} on its path and request; it then acts like
\var{handler} if the predicate returned a true vale, and like
\var{default-handler} if the predicate returned \sharpf.
\end{desc}
\defun{make-host-name-handler}{hostname handler default-handler}{request-handler}
\begin{desc}
The request handler returned by this procedure compares the host
name specified in the request with \var{hostname}: if they match, it
acts like \var{handler}, otherwise, it acts like
\var{default-handler}.
\end{desc}
\defun{make-path-predicate-handler}{predicate handler
default-handler}{request-handler}
\begin{desc}
The request handler returned by this procedure first calls
\var{predicate} on its path; it then acts like \var{handler} if the
predicate returned a true vale, and like \var{default-handler} if
the predicate returned \sharpf.
\end{desc}
\defun{make-path-prefix-handler}{path-prefix handler default-handler}{request-handler}
\begin{desc}
This constructs a request handler that calls \var{handler} on its
argument if \var{path-prefix} (a string) is the first element of the
requested path; it calls \var{handler} on the rest of the path and
the original request. Otherwise, the handler acts like
\var{default-handler}.
\end{desc}
\defun{alist-path-dispatcher}{handler-alist default-handler}{request-handler}
\begin{desc}
This procedure takes as arguments an alist mapping strings to path
handlers, and a default request handler, and returns a handler that
dispatches on its path argument. When the new request handler is
applied to a path
\begin{verbatim}
("foo" "bar" "baz")
\end{verbatim}
it uses the
first element of the path---\ex{foo}---to index into the
alist. If it finds an associated request handler in the alist, it
hands the request off to that handler, passing it the tail of the
path, in this case
\begin{verbatim}
("bar" "baz")
\end{verbatim}
%
On the other hand, if the path is
empty, or the alist search does not yield a hit, we hand off to the
default path handler, passing it the entire original path,
\begin{verbatim}
("foo" "bar" "baz")
\end{verbatim}
%
This procedure is how you say: ``If the first element of the URL's
path is `foo', do X; if it's `bar', do Y; otherwise, do Z.''
The slash-delimited URI path structure implies an associated tree of
names. The request-handler system and the alist dispatcher allow you to
procedurally define the server's response to any arbitrary subtree
of the path space.
Example: A typical top-level request handler is
\begin{alltt}
(define ph
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public\_html"))
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))
("seval" . ,seval-handler))
(rooted-file-handler "/usr/local/etc/httpd/htdocs")))
\end{alltt}
This means:
\begin{itemize}
\item If the path looks like \ex{("h"\ob{} "shivers"\ob{}
"code"\ob{} "web.\ob{}tar.\ob{}gz")}, pass the path
\ex{("shivers"\ob{} "code"\ob{} "web.\ob{}tar.\ob{}gz")} to a
home-directory request handler.
\item If the path looks like \ex{("cgi-\ob{}bin"\ob{} "calendar")},
pass ("calendar") off to the CGI request handler.
\item If the path looks like \ex{("seval"\ob{} \ldots)}, the tail
of the path is passed off to the code-uploading \ex{seval} path
handler.
\item Otherwise, the whole path is passed to a rooted file handler,
who will convert it into a filename, rooted at
\ex{/usr/\ob{}lo\ob{}cal/\ob{}etc/\ob{}httpd/\ob{}htdocs},
and serve that file.
\end{itemize}
\end{desc}
\subsection{Static Content Request Handlers}
The request handlers described in this section are for serving static
content off directory trees in the file system. They live in the
\ex{httpd-file-directory-handlers} structure.
The request handlers in this section eventually call an internal
procedure named \ex{file\=serve} for serving files which implements a
simple directory-generation service using the following rules:
\begin{itemize}
\item If the filename has the form of a directory (i.e., it ends with
a slash), then \ex{file\=serve} actually looks for a file named
\ex{index.html} in that directory.
\item If the filename names a directory, but is not in directory form
(i.e., it doesn't end in a slash, as in
``\ex{/usr\ob{}in\ob{}clu\ob{}de}'' or ``\ex{/usr\ob{}raj}''),
then \ex{file\=serve} sends back a ``301 moved permanently''
message, redirecting the client to a slash-terminated version of the
original URL. For example, the URL
\ex{http://\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu/\ob{}~shi\ob{}vers}
would be redirected to
\ex{http://\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu/\ob{}~shi\ob{}vers/}
\item If the filename names a regular file, it is served to the
client.
\end{itemize}
\defun{rooted-file-handler}{root-dir}{request-handler}
\begin{desc}
This returns a request handler that serves files from a particular
root in the file system. Only the \ex{GET} operation is provided.
The path argument passed to the handler is converted into a
filename, and appended to root-dir. The file name is checked for
\ex{..} components, and the transaction is aborted if it does.
Otherwise, the file is served to the client.
\end{desc}
\defun{rooted-file-or-directory-handler}{root}{request-handler}
\begin{desc}
Dito, but also serve directory indices for directories without
\ex{index.html}.
\end{desc}
\defun{home-dir-handler}{subdir}{request-handler}
\begin{desc}
This procedure builds a request handler that does basic file serving
out of home directories. If the resulting \var{request-handler} is
passed a path of the form \ex{(\var{user} . \var{file-path})}, then it serves the file
\ex{\var{subdir}/\var{file-path}} inside the user's home directory.
The request handler only handles GET requests; the filename is not
allowed to contain \ex{..} elements.
\end{desc}
\defun{tilde-home-dir-handler}{subdir
default-request-handler}{request-handler}
\begin{desc}
This returns request handler that examines the car of the path. If
it is a string beginning with a tilde, e.g., \ex{"~ziggy"}, then the
string is taken to mean a home directory, and the request is served
similarly to a home-dir-handler request handler. Otherwise, the
request is passed off in its entirety to the
\var{default-request-handler}.
\end{desc}
\section{CGI Server}
The procedure(s) described here live in the \ex{httpd-cgi-handlers}
structure.
\defun{cgi-handler}{bin-dir [cgi-bin-path]}{request-handler}
\begin{desc}
Returns a request handler for CGI scripts located in
\var{bin-dir}. \var{Cgi-bin-dir} specifies the value of the
\ex{PATH} variable of the environment the CGI scripts run in. It defaults
to
\begin{verbatim}
/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin
\end{verbatim}
The CGI scripts are called as specified by CGI/1.1\footnote{see
\url{http://hoohoo.ncsa.uiuc.edu/cgi/interface.html} for a sort of
specification.}.
Note that the CGI handler looks at the name of the CGI script to
determine how it should be handled:
\begin{itemize}
\item If the name of the script starts with `\ex{nph-}', its reply
is read, the RFC~822-fields like \ex{Content-Type} and \ex{Status}
are parsed and the client is sent back a real HTTP reply,
containing the rest of the script's output.
\item If the name of the script doesn't start with `\ex{nph-}',
its output is sent back to the client directly. If its return code
is not zero, an error message is generated.
\end{itemize}
\end{desc}
\section{Scheme-Evaluating Request Handlers}
The \ex{httpd-seval-handlers} structure contains a handler which
demonstrates how to safely evaluate Scheme code uploaded from the
client to the server.
\defvar{seval-handler}{request-handler}
\begin{desc}
This request handler is suitable for receiving code entered into an
HTML text form. The Scheme code being uploaded is being \ex{POST}ed
to the server (from a form). The code should be URI-encoded in the
URL as \texttt{program=}$\left<\mathrm{stuff}\right>$.
$\mathrm{stuff}$ must be an (URI-encoded) Scheme expression which
the handler evaluates in a separate subprocess. (It waits for 10
seconds for a result, then kills the subprocess.) The handler then
prints the return values of the Scheme code.
\end{desc}
The following structures define environments that are \RnRS without
features that could examine or effect the file system. You can also
use them as models of how to execute code in other protected
environments in \scm.
\subsection{The \protect{\texttt{loser}} structure}
The \ex{loser} package exports only one procedure:
\begin{defundesc}{loser}{name}{nothing}
Raises an error like ``Illegal call \var{name}''.
\end{defundesc}
\subsection{The \protect{\texttt{toothless}} structure}
The \ex{toothless} structure contains everything of \RnRS except
that following procedure cause an error if called:
\begin{itemize}
\item \ex{call-with-input-file}
\item \ex{call-with-output-file}
\item \ex{load}
\item \ex{open-input-file}
\item \ex{open-output-file}
\item \ex{transcript-on}
\item \ex{with-input-from-file}
\item \ex{with-input-to-file}
\item \ex{eval}
\item \ex{interaction-environment}
\item \ex{scheme-report-environment}
\end{itemize}
\subsection{The \protect{\texttt{toothless-eval}} structure}
\begin{defundesc}{eval-safely} {expression} {any result}
Creates a brand-new structure, imports the \ex{toothless} structure,
and evaluates \semvar{expression} in it. When the evaluation is
done, the environment is thrown away, so \semvar{expression}'s
side-effects don't persist from one \ex{eval\=safely} call to the
next. If \semvar{expression} raises an error exception,
\ex{eval-safely} returns \sharpf.
\end{defundesc}
\section{Writing Request Handlers}
\subsection{Parsing HTML Forms}
In HTML forms, field data are turned into a single string, of the form
\texttt{\synvar{name}=\synvar{val}\&\synvar{name}=\synvar{val}\ldots}.
The \ex{parse-html-forms} structure provides simple functionality to
parse these strings.
\defun{parse-html-form-query}{string}{alist}
\begin{desc}
This parses \verb|"foo=x&bar=y"| into \verb|(("foo" . "x") ("bar" .
"y"))|. Substrings are plus-decoded (i.-e.\ plus characters are
turned into spaces) and then URI-decoded.
This implementation is
slightly sleazy as it will successfully parse a string like
\verb|"a&b=c&d=f"| into \verb|(("a&b" . "c") ("d" . "f"))| without
a complaint.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

71
doc/latex/intro.tex
View File

@ -1,71 +0,0 @@
\chapter{Overview}\label{sec:intro}
\section{What's SUnet?}
The Scheme Untergrund Networking Package (SUnet, for short) contains a
set of libraries for doing Internet hacking from scsh. It includes:
\begin{description}
\item[The SUnet Web server]
This is a complete implementation of an HTTP 1.0 server in Scheme.
The server is accompanied some libraries which may also be used separately:
\begin{itemize}
\item URI and URL parsers and unparsers
\item a library for writing CGI scripts in Scheme
\item server extensions for interfacing to CGI scripts
\item server extensions for uploading Scheme code
\item simple structured HTML output library
\end{itemize}
\item[The SUnet ftp daemon]
This is a complete anonymous ftp server in Scheme.
\item[ftp client library] This library allows you to access ftp
servers programmatically.
\item[netrc library] This library parses authentication information
contained in \verb|~/.netrc|.
\item[SMTP client library] This library allows you to forge mail from
the comfort of your own Scheme process.
\item[POP3 client library]
This library allows you to access your POP3 mailbox from inside scsh.
\item[RFC822 header library] This library parses email-style headers.
\item[Daytime and Time protocol client library]
This library lets you find out what time it is without paying for a
Rolex.
\item[DNS client library] This is a fairly complete, multithreaded DNS
library.
\item[An \texttt{ls} clone] This library Displays Unix-style directory
listings without running \texttt{ls}.
\end{description}
\section{Obtaining the system}
The SUnet code is available
\urlhd{http://www.scsh.net/sunet/}{here}{from
\url{http://www.scsh.net/sunet/}}. To run the code, you need
version 0.6.3 or later of \urlhd{http://www.scsh.net/}{scsh}{scsh from
\url{http://www.scsh.net/}}.
\section{How to use the packages}
Untar the SUnet distribution somewhere. Fire up scsh and load the
SUnet \texttt{packages.scm} file into the configuration package.
After that, all structures defined by SUnet are available:
%
\begin{alltt}
atari-2600[72] scsh-0.6.3
Welcome to scsh 0.6.3 (Health Reform)
Type ,? for help.
> ,config ,load packages.scm
modules.scm
> ,open ftp
Load structure ftp (y/n)? y
[netrc netrc.scm]
[ftp ftp.scm]
> ; call library code
> ,exit
atari-2600[73]
\end{alltt}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

133
doc/latex/man.t2p
View File

@ -1,133 +0,0 @@
% man.t2p
% Dorai Sitaram
% Feb 6, 2000
% This file contains the tex2page macros needed to process
% the scsh LaTeX document scsh-n.n.n/doc/scsh-manual/man.tex.
% Copy (or link) this file alongside man.tex and run
%
% tex2page man
\input css.t2p
\htmlmathstyle{no-image}
\let\pagebreak\relax
\let\small\relax
%\let\PRIMtableofcontents\tableofcontents
%\def\tableofcontents{\chapter*{Contents}\PRIMtableofcontents}
\def\subtitle#1{\def\savesubtitle{#1}}
\def\maketitle{
\subject{\TIIPtitle}
{\bf \hr}
\rightline{\savesubtitle}
\bigskip\bigskip
\bigskip\bigskip
{\bf\TIIPauthor}
{\bf\hr}
}
\let\PRIMdocument\document
\def\document{\PRIMdocument
\let\ttchars\relax
\let\ttt\tt
%\def\~{\rawhtml~\endrawhtml}
\def\~{\char`\~}
\def\cd#1{{\tt\def\\{\char`\\}\defcsactive\${\char`\$}\defcsactive\~{\char`\~}\defcsactive\&{\char`\&}#1}}
\def\cddollar{\undefcsactive\$}
\def\cdmath{\undefcsactive\$}
\def\codeallowbreaks{\relax}
\def\defvarx#1#2{\index{#1}\leftline{{\tt #1} \qquad #2}}
\let\PRIMflushright\flushright
\def\flushright{\PRIMflushright\TIIPtabularborder=0 }
\let\PRIMfigure\figure
\let\PRIMendfigure\endfigure
\def\figure{\par\hrule\PRIMfigure}
\def\endfigure{\PRIMendfigure\hrule\par}
\let\PRIMtable\table
\let\PRIMendtable\endtable
\def\table{\par\hrule\PRIMtable}
\def\endtable{\PRIMendtable\hrule\par}
\imgdef\vdots{\bf.\par.\par.}
%\evalh{
%
%(define all-blanks?
% (lambda (s)
% (andmap
% char-whitespace?
% (string->list s))))
%
%}
%
%
%\def\spaceifnotempty{\evalh{
%
%(let ((x (ungroup (get-token))))
% (unless (all-blanks? x)
% (emit #\space)))
%
%}}
\def\spaceifnotempty#1{%
\def\TEMP{#1}%
\ifx\TEMP\empty\else\ \fi}
\def\dfnix#1#2#3#4{\leftline{{\tt(#1\spaceifnotempty{#2}{\it#2})} \quad $\longrightarrow$ \quad {\it #3} \qquad (#4)} \index}
%\def\ex#1{{\tt #1}}
%\let\ex\texttt
\def\l#1{lambda (#1)}
\def\lx#1{lambda {#1}}
%\def\notenum#1{}
%\def\project#1{}
%\def\var#1{{\it #1\/}}
%\let\var\textit
%\def\vari#1#2{\mbox{{\it #1\/}\undefcsactive\$$_{#2}$}}
%\def\vari#1#2{\textit{#1}$_{#2}$}
\renewenvironment{boxedfigure}{\def\srecomment#1{\\#1\\}%
\begin{figure}\pagestyle}{\end{figure}}
\newenvironment{centercode}{\begin{code}}{\end{code}}
\def\setupcode{\tt%
\def\\{\char`\\}%
\defcsactive\${\$}%
\def\evalto{==> }%
\defcsactive\%{\%}\obeywhitespace}
\newenvironment{code}{\begin{quote}\setupcode\GOBBLEOPTARG}
{\end{quote}}
\newenvironment{codebox}{\begin{tableplain}\bgroup\setupcode\GOBBLEOPTARG}
{\egroup\end{tableplain}}
\renewenvironment{desc}{\begin{quote}}{\end{quote}}
\renewenvironment{exampletable}{%
\def\header#1{\\\leftline{#1}\\}%
\def\splitline#1#2{\\\leftline{#1}\\\leftline{#2}}%
\begin{tabular}{}}{\end{tabular}}
\newenvironment{tightcode}{\begin{code}}{\end{code}}
\renewenvironment{widecode}{\begin{code}}{\end{code}}
\renewenvironment{inset}{\begin{quote}}{\end{quote}}
\renewenvironment{leftinset}{\begin{quote}}{\end{quote}}
\renewenvironment{tightinset}{\begin{quote}}{\end{quote}}
\renewenvironment{tightleftinset}{\begin{quote}}{\end{quote}}
}

84
doc/latex/man.tex
View File

@ -1,84 +0,0 @@
% -*- latex -*-
% This is the reference manual for the Scheme Untergrund Networking Package.
\documentclass[twoside]{report}
\usepackage{code,boxedminipage,makeidx,palatino,ct,
headings,mantitle,array,matter,mysize10,tex2page}
\usepackage[latin1]{inputenc}
\usepackage{alltt}
\usepackage{xspace}
\texonly
% tex2page defines \url and hyperref loads the package url
% but setting \url to \relax satisfies \newcommand
\let\url\relax
\input{pdfcond}
\ifpdf
\usepackage[pdftex,hyperindex,
pdftitle={sunet manual, release 2.0},
pdfauthor={Olin Shivers, Mike Sperber, Martin Gasbichler, Eric Marsden
and Andreas Bernauer}
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue,
pdfstartview=FitH,pdfview=FitH]{hyperref}
\usepackage{thumbpdf}
\usepackage{tocbibind}
\else
\usepackage[dvipdfm,hyperindex,hypertex,
pdftitle={sunet manual, release 2.0},
pdfauthor={Olin Shivers, Mike Sperber, Martin Gasbichler, Eric Marsden
and Andreas Bernauer}
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue,
pdfstartview=FitH,pdfview=FitH]{hyperref}
\fi
\endtexonly
% Style issues
\parskip = 3pt plus 3pt
\sloppy
\input{decls}
\makeindex
%%% End preamble
\begin{document}
\frontmatter
\title{SUnet Reference Manual}
\subtitle{For SUnet release 2.0}
\author{Dr. S, Dr. S, Martin Gasbichler, Eric Marsden, Andreas Bernauer}
\date{January 2003}
\mainmatter
\maketitle
\begin{abstract}
\noindent The Scheme Untergrund Network Package (\textit{SUnet} for short) is
a set of libraries for Internet hacking. Among the implemented
protocols are server-side http, client-side ftp, server-side ftp,
client-side DNS, client-side nettime, client-side POP3, client-side
SMTP. SUnet also contains a number of libraries for Web
programming: a small package for outputting HTML, a CGI library, as
well as some other utilities.
\end{abstract}
\tableofcontents
\include{intro}
\include{httpd}
\include{cgi-script}
\include{ftpd}
\include{ftp}
\include{netrc}
\include{uri}
\include{url}
\include{rfc822}
\include{nettime}
\include{smtp}
\include{pop3}
\include{dns}
\backmatter
\printindex
\end{document}

76
doc/latex/mantitle.sty
View File

@ -1,76 +0,0 @@
% This is the title page style stolen from the Texinfo design,
% and expressed as a LaTeX style option. It is useful for manuals.
%
% Note that I play some *really* revolting games here to override
% the vertical and horizontal margins temporarily for the title page.
% The layout assumes you have 8.5" x 11" paper. You'd have to redo this
% for A4 or another size.
% -Olin 7/94
% Fonts for title page:
\DeclareFixedFont{\titlefont}%
{\encodingdefault}{\familydefault}{bx}{\shapedefault}{20.5pt}
\DeclareFixedFont{\authorfnt}%
{\encodingdefault}{\familydefault}{bx}{\shapedefault}{14.4pt}
\DeclareFixedFont{\subtitlefnt}%
{\encodingdefault}{\familydefault}{m}{\shapedefault}{11}
%\def\authorrm{\normalfont\selectfont\fontseries{bx}\fontsize{14.4}{14.4}}
%\def\subtitlefnt{\normalfont\selectfont\fontsize{11}{11}}
\newskip\titlepagetopglue \titlepagetopglue = 2.5in
\newlength{\widewidth}
\setlength{\widewidth}{6.5in}
\newlength{\negwidemargin}
\setlength{\negwidemargin}{-\oddsidemargin} % Reset the margin
\addtolength{\negwidemargin}{-1in} % to edge of page
\addtolength{\negwidemargin}{1in} % Then move right one inch.
%\def\wideline#1{\hbox to 0pt{\hspace\negwidemargin\hbox to\widewidth{#1}}}
\def\wideline#1{\hbox{\makebox[0pt][l]{\hspace\negwidemargin\hbox to\widewidth{#1}}}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\def\maketitle{\begin{titlepage}
\thispagestyle{empty}
\let\footnotesize\small \let\footnoterule\relax
\null
\parindent=0pt
\def\subtitlefont{\normalbaselineskip = 13pt \normalbaselines \subtitlefnt}%
\def\authorfont{\normalbaselineskip = 16pt \normalbaselines \authorfnt}%
%
% Leave some space at the very top of the page.
\vspace*{-1in}\vspace*{-\topmargin}\vspace*{-\headheight}\vspace*{-\headsep}
\vglue\titlepagetopglue
%
\wideline{\titlefont \@title \hfill} % title
% \vskip4pt
\vskip -0.3\baselineskip
\wideline{\leaders\hrule height 4pt\hfill}
\wideline{\hfill\subtitlefont\begin{tabular}[t]{@{}r@{}}\@subtitle%
\\\@date%
\end{tabular}} % subtitle
%
% author
\vskip 0pt plus 1filll
\wideline{\authorfont \begin{tabular}[t]{@{}c@{}}\@author
\end{tabular}\hfill}
%
% \vskip4pt
\vskip -0.3\baselineskip
\wideline{\leaders\hrule height 2pt\hfill}
% This weirdness puts the bottom line 2.75 in from the bottom of
% an 11in page.
\vskip \textheight \vskip \headsep \vskip \headheight
\vskip \topmargin \vskip 1in \vskip -11in \vskip 2.75in
\gdef\@author{}\gdef\@title{}\gdef\@subtitle{}\let\maketitle\relax
\end{titlepage}
\setcounter{page}{2}
}
\def\subtitle#1{\gdef\@subtitle{#1}}
\def\@subtitle{}

16
doc/latex/matter.sty
View File

@ -1,16 +0,0 @@
%&latex -*- latex -*-
% Implement the \frontmatter, \mainmatter, and \backmatter macros,
% so I can use them in reports, not just books.
\newif\if@mainmatter \@mainmattertrue
\newcommand\frontmatter{%
\cleardoublepage\@mainmatterfalse\pagenumbering{roman}}
\newcommand\mainmatter{%
\cleardoublepage\@mainmattertrue%
\pagenumbering{arabic}\setcounter{page}{1}}
\newcommand\backmatter{%
\if@openright\cleardoublepage\else\clearpage\fi%
\@mainmatterfalse}

22
doc/latex/mysize10.sty
View File

@ -1,22 +0,0 @@
%&latex -*- latex -*-
\if@twoside
\oddsidemargin 44pt
\evensidemargin 82pt
\marginparwidth 107pt
\else
\oddsidemargin 63pt
\evensidemargin 63pt
\marginparwidth 90pt
\fi
\marginparsep 11pt
\topmargin 27pt
\headheight 12pt
\headsep 25pt
\topskip = 10pt
\footskip 30pt
\textheight = 43\baselineskip
\advance\textheight by \topskip
\textwidth 345pt
\endinput

61
doc/latex/netrc.tex
View File

@ -1,61 +0,0 @@
\chapter{Parsing Netrc Files}\label{cha:netrc}
%
The \ex{netrc} structures provides procedures to parse authentication
information contained in \ex{~/.netrc}.
On Unix systems the netrc file may contain information allowing
automatic login to remote hosts. The format of the file is defined in
the \ex{ftp(1)} manual page. Example lines are
%
\begin{verbatim}
machine ondine.cict.fr login marsden password secret
default login anonymous password user@site
\end{verbatim}
%
The netrc file should be protected by appropriate permissions, and
(like \ex{/usr/bin/ftp}) this library will refuse to read the file if it is
badly protected. (unlike \ex{ftp} this library will always refuse
to read the file----\ex{ftp} refuses it only if the password is
given for a non-default account). Appropriate permissions are set if
only the user has permissions on the file.
\defun{netrc-machine-entry}{host accept-default? [file-name]}{netrc-entry-or-\sharpf}
\begin{desc}
This procedure looks for the entry related to given host in the
user's netrc file. The host is specified in \var{host}.
\var{Accept-default?} specifies whether \ex{netrc-machine-entry}
should fall back to the default entry if there is no macht for
\var{host} in the netrc file. If specified, \var{file-name}
specifies an alternate file name for the netrc data. It defaults to
\ex{.netrc} in the current user's home directory.
\ex{Netrc-machine-entry} returns a netrc entry (see below) if it was
able to find the requested information; if not, it returns \sharpf.
If the netrc file had inappropriate permissions, \ex{netrc-machine-entry}
raises an error.
\end{desc}
\defun{netrc-entry?}{thing}{boolean}
\defunx{netrc-entry-machine}{netrc-entry}{string}
\defunx{netrc-entry-login}{netrc-entry}{string-or-\sharpf}
\defunx{netrc-entry-password}{netrc-entry}{string-or-\sharpf}
\defunx{netrc-entry-account}{netrc-entry}{string-or-\sharpf}
\begin{desc}
\ex{Netrc-entry?} is the predicate for netrc entries. The other
procedures are selectors for netrc entries as returned by
\ex{netrc-machine-entry}. They return \sharpf{} if the netrc file
didn't contain a binding for the corresponding field.
\end{desc}
\defun{netrc-macro-definitions}{[file-name]}{alist}
\begin{desc}
This returns the macro definitions from the netrc files, represented
as an alist mapping macro names---represented as strings---to
definitions---represented as lists of strings.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

57
doc/latex/nettime.tex
View File

@ -1,57 +0,0 @@
\chapter{Time and Daytime}\label{cha:ntp}
Many Unix hosts provide a RFC~867 Daytime service which sends the
current date and time as a human-readable character string. The
daytime service is typically served on port 13 as both TCP and UDP.
The RFC~868 Time protocol provides a site-independent, machine
readable date and time. The Time service is typically served
on port 37 as TCP and UDP. The idea is that you can confirm your
system's idea of the time by polling several independent sites on the
network.
\section{Daytime}
The \ex{rfc867} structure contains an interface to Daytime protocol.
\defun{rfc867-daytime/tcp}{host}{string}
\defunx{rfc867-daytime/udp}{host [timeout-or-\sharpf]}{string-or-\sharpf}
\begin{desc}
These procedures asks \var{host} about the current daytime and
return the host's answer (e.g., ``Thursday, April 4,
2'').
\ex{Rfc867-daytime/tcp} uses the TCP variant of the protocol.
\ex{Rfc867-daytime/udp} uses UDP and sends a single request to the
server. It allows the specification of an optional timeout; if not
specified or \sharpf{}, \ex{Rfc867-daytime/udp} will wait
indefinitely for an answer. If the answer from the server doesn't
arrive within the specified time, \ex{rfc867-daytime/udp} returns
\sharpf.
\end{desc}
\section{Time}
The \ex{rfc868} structure contains an interface to the Time protocol.
\defun{rfc868-time/tcp}{host}{string}
\defunx{rfc868-time/udp}{host [timeout-or-\sharpf]}{string-or-\sharpf}
\begin{desc}
These procedures asks \var{host} about the current time and return
the host's answer. This is the number of second since 1970, just as
with scsh's \texttt{time} procedure.
\ex{rfc868-time/tcp} uses the TCP variant of the protocol.
\ex{rfc868-time/udp} uses UDP and sends a single request to the
server. It allows the specification of an optional timeout; if not
specified or \sharpf{}, \ex{rfc868-time/udp} will wait
indefinitely for an answer. If the answer from the server doesn't
arrive within the specified time, \ex{rfc868-time/udp} returns
\sharpf.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

14
doc/latex/pdfcond.tex
View File

@ -1,14 +0,0 @@
\newif\ifpdf
\ifx\pdfoutput\undefined
\pdffalse % we are not running PDFLaTeX
\else
\pdfoutput=1 % we are running PDFLaTeX
\pdftrue
\fi
% Then use your new variable \ifpdf
% \ifpdf
% \usepackage[pdftex]{graphicx}
% \pdfcompresslevel=9
% \else
% \usepackage{graphicx}
% \fi

98
doc/latex/pop3.tex
View File

@ -1,98 +0,0 @@
\chapter{Using POP3}\label{cha:pop3}
%
The \ex{pop3} structure provides a client for the POP3 protocol that
allows access to email on a maildrop server. It is often used in
configurations where users connect from a client machine which doesn't
have a permanent network connection or isn't always turned on,
situations which make local SMTP delivery impossible. It is the most
common form of email access provided by ISPs.
Two types of authentication are commonly used. The first, most basic
type involves sending a user's password in clear over the network, and
should be avoided. (Unfortunately, many POP3 clients only implement this
basic authentication.) The digest authentication system involves the
server sending the client a ``challenge'' token; the client encodes
this token with the pass phrase and sends the coded information to the
server. This method avoids sending sensitive information over the
network. Both methods are implemented by \ex{pop3}.
Once connected, a client may request information about the number and
size of the messages waiting on the server, download selected messages
(either their headers or the entire content), and delete selected
messages.
The procedures defined here raise an error detectable via
\ex{pop3-error?} upon protocol errors with the POP3 server.
\defun{pop3-connect}{[host-or-\sharpf] [login-or-\sharpf]
[password-or-\sharpf] [log-port]}{connection}
\begin{desc}
This procedure connects to the maildrop server named \var{host},
and logs in using the provided login name and password. Any of
these can be omitted or \sharpf, in which case the procedure uses
defaults: \ex{MAILHOST} for the host, and \ex{~/.netrc}-provided
values for login and password. If \var{log-port} is provided, the
conversation to the server is logged to the specified output port.
\ex{Pop3-connect} returns a value representing the connection to the
POP3 server, to be used in the procedures below.
\end{desc}
\defun{pop3-stat}{connection}{number bytes}
\begin{desc}
This returns the number of messages and the number of bytes waiting in the
maildrop.
\end{desc}
Most of the following procedures accept a \var{msgid} argument which
specifies a message number, which ranges from 1 for the first message
to the number returned by \ex{pop3-stat}.
\defun{pop3-retrieve-message}{connection msgid}{headers message}
\begin{desc}
This downloads message number \var{msgid} from the mailhost.
It returns the headers as an alist of field names and bodies; the
names are symbols, the bodies are strings. (These are obtained
using the \ex{rfc822} structure, see Section~\ref{cha:rfc822}.)
The message is returned as a list of strings, each string
representing a line of the message.
\end{desc}
\defun{pop3-retrieve-headers}{connection msgid}{headers}
\begin{desc}
This downloads the headers of message number \var{msgid}. It
returns the headers in the same format as \ex{pop3-retrieve-message}.
\end{desc}
\defun{pop3-last}{connection}{msgid}
\begin{desc}
This returns the highest accessed message-id number for the current
session. (This isn't in the RFC, but seems to be supported by several
servers.)
\end{desc}
\defun{pop3-delete}{connection msgid}{undefined}
\begin{desc}
This mark message number \var{msgid} for deletion. The message will
not be deleted until the client logs out.
\end{desc}
\defun{pop3-reset}{connection}{undefined}
\begin{desc}
This marks any messages which have been marked for deletion.
\end{desc}
\begin{desc}{pop3-quit}{connection}{undefined}
This closes the connection with the mailhost.
\end{desc}
\defun{pop3-error?}{thing}{boolean}
\begin{desc}
This returns \sharpt{} if \var{thing} is a \ex{pop3-error} object,
otherwise \sharpf.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

107
doc/latex/rfc822.tex
View File

@ -1,107 +0,0 @@
\chapter{RFC~822 Library}\label{cha:rfc822}
%
The \ex{rfc822} structure provides rudimentary support for parsing
headers according to RFC~822 \textit{Standard for the format of ARPA
Internet text messages}. These headers show up in SMTP messages,
HTTP headers, etc.
An RFC~822 header field consists of a \textit{field name} and a
\textit{field body}, like so:
%
\begin{verbatim}
Subject: RFC 822 can format itself in the ARPA
\end{verbatim}
%
Here, the field name is `\ex{Subject}', and the field name is `\ex{
RFC 822 can format itself in the ARPA}' (note the leading space).
The field body can be spread over several lines:
%
\begin{verbatim}
Subject: RFC 822 can format itself
in the ARPA
\end{verbatim}
%
In this case, RFC~822 specifies that the meaning of the field body is
actually all the lines of the body concatenated, without the
intervening line breaks.
The \ex{rfc822} structure provides two sets of parsing
procedures---one represents field bodies in the RFC-822-specified
meaning, as a single string, the other (with \ex{-with-line-breaks}
appended to the names) reflects the line breaks and represents the
bodies as a list of string, one for each line. The latter set only
marginally useful---mainly for code that needs to output headers in
the same form as they were originally provided.
\defun{read-rfc822-field}{[port] [read-line]}{name body}
\defun{read-rfc822-field-with-line-breaks}{[port] [read-line]}{name body-lines}
\begin{desc}
Read one field from the port, and return two values:
%
\begin{description}
\item[\var{name}] This is a symbol describing the field
name, such as \ex{subject} or \ex{to}. The symbol consists of all
lower-case letters.\footnote{In fact, it \ex{read-rfc822-field}
uses the preferred case for symbols of the underlying Scheme
implementation which, in the case of scsh, happens to be lower-case.}
\item[\var{body} or \var{body-lines}] This is the field body.
\var{Body} is a single string, \var{body-lines} is a list of
strings, one for each line of the body. In each case,
the terminating \ex{cr}/\ex{lf}'s (but nothing else) are
trimmed from each string.
\end{description}
%
When there are no more fields---EOF or a blank line has terminated
the header section---then both procedures returns [\sharpf\
\sharpf].
\var{Port} is an optional input port to read from---it defaults to
the value of \ex{(current-input-port)}.
\var{Read-line} is an optional parameter specifying a procedure of
one argument (the input port) used to read the raw header lines.
The default used by these procedures terminates lines with
either \ex{cr}/\ex{lf} or just \ex{lf}, and it trims the terminator
from the line. This procedure should trim the terminator of the
line, so an empty line is returned as an empty string.
The procedure raises an error if the syntax of the read field (the
line returned by the read-line-function) is illegal according to
RFC~822.
\end{desc}
\defun{read-rfc822-headers} {[port] [read-line]} {alist}
\defunx{read-rfc822-headers-with-line-breaks} {[port] [read-line]} {alist}
\begin{desc}
This procedure reads in and parses a section of text that looks like
the header portion of an RFC~822 message. It returns an association
list mapping field names (a symbol such as \ex{date} or \ex{subject}) to
field bodies. The representation of the field bodies is as with
\ex{read-rfc822-field} and \ex{read-rfc822-field-with-line-breaks}.
These procedures preserve the order of the header fields. Note that
several header fields might share the same field name---in that
case, the returned alist will contain several entries with the same
\ex{car}.
\var{Port} and \var{read-line} are as with \ex{read-rfc822-field}
and \ex{read-rfc822-field-with-line-breaks}.
\end{desc}
\defun{rfc822-time->string}{time}{string}
\begin{desc}
This formats a time value (as returned by scsh's \ex{time})
according to the requirements of the RFC~822 \ex{Date} header
field. The format looks like this:
%
\begin{verbatim}
Sun, 06 Nov 1994 08:49:37 GMT
\end{verbatim}
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

8
doc/latex/skeleton.tex
View File

@ -1,8 +0,0 @@
\section{Section-Title}
%
\begin{description}
\item[Used files:]
\item[Name of the package:]
\end{description}
%
Not implemented yet.

123
doc/latex/smtp.tex
View File

@ -1,123 +0,0 @@
\chapter{SMTP Client}\label{cha:smtp}
%
The \ex{smtp} structure provides an client library for the Simple Mail
Transfer Protocol, commonly used for sending email on the Internet.
This library provides a simple wrapper for sending complete emails as
well as procedures for composing custom SMTP transactions.
Some of the procedures described here return an SMTP reply code. For
details, see RFC~821.
\defun{smtp-send-mail}{from to-list headers body [host]}{undefined}
\defunx{smtp-error?}{thing}{boolean}
\defunx{smtp-recipients-rejected-error?}{thing}{boolean}
\begin{desc}
This emails message \var{body} with headers \var{headers} to
recipients in list \var{to-list}, using a sender address \var{from}.
The email is handed off to the SMTP server running on \var{host};
default is the local host. \var{Body} is either a list of strings
representing the lines of the message body or an input port which is
exhausted to determine the message body. \var{Headers} is an
association lists, mapping symbols representing RFC~822 field names
to strings representing field bodies.
If some transaction-related error happens, \ex{smtp-send-mail}
signals an \ex{smtp-error} condition with predicate
\ex{smtp-error?}. More specifically, it raises an
\ex{smtp-recipients-rejected-error} (a subtype of \ex{smtp-error})
if some recipients were rejected. For \ex{smtp-error}, the
arguments to the \ex{signal} call are the error code and the error
message, represented as a list of lines. For
\ex{smtp-recipients-rejected-error}, the arguments are reply code
700 and an association list whose elements are of the form
\ex{(\var{loser-recipient} \var{code} . \var{text})}---that is, for
each recipient refused by the server, you get the error data sent
back for that guy. The success check is \ex{(< code 400)}.
\end{desc}
\defun{smtp-expand}{name host}{code text}
\defunx{smtp-verify}{name host}{code text}
\defunx{smtp-get-help}{host [details]}{code text-list}
\begin{desc}
These three are simple queries of the server as stated in the
RFC~821: \ex{smtp-expann} asks the server to confirm that the
argument identifies a mailing list, and if so, to return the
membership of that list. The full name of the users (if known) and
the fully specified mailboxes are returned in a multiline reply.
\ex{Smtp-verify} asks the receiver to confirm that the argument
identifies a user. If it is a user name, the full name of the user
(if known) and the fully specified mailbox are returned.
\ex{Smtp-get-help} causes the server to send helpful information.
The command may take an argument (\var{details}) (e.g., any command
name) and return more specific information as a response.
\end{desc}
\defun{smtp-connect}{host [port]}{smtp-connection}
\begin{desc}
\ex{Smtp-connect} returns an SMTP connection value that represents
a connection to the SMTP server.
\end{desc}
\defun{smtp-transactions}{smtp-connection transaction1 ...}{code text-list}
\defunx{smtp-transactions/no-close}{smtp-connection transaction1 ...}{code text-list}
\begin{desc}
These procedures make it easy to do simple sequences of SMTP
commands. \var{Smtp-connection} must be an SMTP connection as
returned by \ex{smtp-connect}. The \var{transaction} arguments must
be transactions as returned by the procedures below.
\ex{Smtp-transactions} and \ex{smtp-transactions/no-close} execute
the transactions specified by the arguments.
For each transaction,
\begin{itemize}
\item If the transaction's reply code is 221 or 421 (meaning the socket has
been closed), then the transaction sequence is aborted, and
\ex{smtp-transactions}/\ex{smtp-transactions/no-close} return the
reply code and text from that transaction.
\item If the reply code is an error code (in the four- or five-hundred range),
the transaction sequence is aborted, and the fatal transaction's code
and text values are returned. \ex{Smtp-transactions} will additionally
close the socket for you; \ex{smtp-transactions/no-close} will not.
\item If the transaction is the last in the transaction sequence,
its reply code and text are returned.
\item Otherwise, we throw away the current reply code and text, and
proceed to the next transaction.
\end{itemize}
%
\ex{Smtp-transactions} closes the socket after the transaction. (The
\ex{smtp-quit} transaction, when executed, also closes the transaction.)
If the socket should be kept open in the case of an abort, use
\ex{Smtp-transactions/no-close}.
\end{desc}
\defunx{smtp-helo}{local-host-name}{smtp-transaction}
\defunx{smtp-mail}{sender-address}{smtp-transaction}
\defunx{smtp-rcpt}{destination-address}{smtp-transaction}
\defunx{smtp-data}{socket message}{smtp-transaction}
\defunx{smtp-send}{sender-address}{smtp-transaction}
\defunx{smtp-soml}{sender-address}{smtp-transaction}
\defunx{smtp-saml}{sender-address}{smtp-transaction}
\defvarx{smtp-rset}{smtp-transaction}
\defunx{smtp-vrfy}{user}{smtp-transaction}
\defunx{smtp-expn}{user}{smtp-transaction}
\defunx{smtp-help}{details}{smtp-transaction}
\defvarx{smtp-noop}{smtp-transaction}
\defvarx{smtp-quit}{smtp-transaction}
\defvarx{smtp-turn}{smtp-transaction}
\begin{desc}
These transactions represent the commands of the SMTP protocol for
use in \ex{smtp-transactions} and \ex{smtp-transactions/no-close},
i.e.\ they send the corresponding command along with the argument(s),
if any. For details, consult RFC~821.
The \ex{smtp-quit} transaction, in addition to sending a \ex{QUIT}
command to the SMTP server, also closes the socket of its SMTP
connection.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

168
doc/latex/uri.tex
View File

@ -1,168 +0,0 @@
\chapter{Parsing and Processing URIs}\label{cha:uri}
The \ex{uri} structure contains a library for dealing with URIs.
\section{Notes on URI Syntax}
A URI (Uniform Resource Identifier) is of following syntax:
%
\begin{inset}
[\var{scheme}] \verb|:| \var{path} [\verb|?| \var{search}] [\verb|#| \var{fragid}]
\end{inset}
%
Parts in brackets may be omitted.
The URI contains characters like \verb|:| to indicate its different
parts. Some special characters are \emph{escaped} if they are a
regular part of a name and not indicators for the structure of a URI.
Escape sequences are of following scheme: \verb|%|\var{h}\var{h} where \var{h}
is a hexadecimal digit. The hexadecimal number refers to the
ASCII of the escaped character, e.g.\ \verb|%20| is space (ASCII
32) and \verb|%61| is `a' (ASCII 97). This module
provides procedures to escape and unescape strings that are meant to
be used in a URI.
\section{Procedures}
\defun{parse-uri} {uri-string } {scheme path search
frag-id} \label{proc:parse-uri}
\begin{desc}
Parses an \var{uri\=string} into its four fields.
The fields are \emph{not} unescaped, as the rules for
parsing the \var{path} component in particular need unescaped
text, and are dependent on \var{scheme}. The URL parser is
responsible for doing this. If the \var{scheme}, \var{search}
or \var{fragid} portions are not specified, they are \sharpf.
Otherwise, \var{scheme}, \var{search}, and \var{fragid} are
strings. \var{path} is a non-empty string list---the path split
at slashes.
\end{desc}
Here is a description of the parsing technique. It is inwards from
both ends:
\begin{itemize}
\item First, the code searches forwards for the first reserved
character (\verb|=|, \verb|;|, \verb|/|, \verb|#|, \verb|?|,
\verb|:| or \verb|space|). If it's a colon, then that's the
\var{scheme} part, otherwise there is no \var{scheme} part. At
all events, it is removed.
\item Then the code searches backwards from the end for the last reserved
char. If it's a sharp, then that's the \var{fragid} part---remove it.
\item Then the code searches backwards from the end for the last reserved
char. If it's a question-mark, then that's the \var{search}
part----remove it.
\item What's left is the path. The code split it at slashes. The
empty string becomes a list containing the empty string.
\end{itemize}
%
This scheme is tolerant of the various ways people build broken
URI's out there on the Net\footnote{So it does not absolutely conform
to RFC~1630.}, e.g.\ \verb|=| is a reserved character, but used
unescaped in the search-part. It was given to me\footnote{That's
Olin Shivers.} by Dan Connolly of the W3C and slightly modified.
\defun{unescape-uri}{string [start] [end]}{string}
\begin{desc}
\ex{Unescape-uri} unescapes a string. If \var{start} and/or \var{end} are
specified, they specify start and end positions within \var{string}
should be unescaped.
\end{desc}
%
This procedure should only be used \emph{after} the URI was parsed,
since unescaping may introduce characters that blow up the
parse---that's why escape sequences are used in URIs.
\defvar{uri-escaped-chars}{char-set}
\begin{desc}
This is a set of characters (in the sense of SRFI~14) which are
escaped in URIs. These are the
following characters: \verb|$|, \verb|-|, \verb|_|, \verb|@|, %$
\verb|.|, \verb|&|, \verb|!|, \verb|*|, \verb|\|, \verb|"|,
\verb|'|, \verb|(|, \verb|)|, \verb|,|, \verb|+|, and all other
characters that are neither letters nor digits (such as space and
control characters).
\end{desc}
\defun{escape-uri} {string [escaped-chars]} {string}
\begin{desc}
This procedure escapes characters of \var{string} that are in
\var{escaped\=chars}. \var{Escaped\=chars} defaults to
\ex{uri\=escaped\=chars}.
\end{desc}
%
Be careful with using this procedure to chunks of text with
syntactically meaningful reserved characters (e.g., paths with URI
slashes or colons)---they'll be escaped, and lose their special
meaning. E.g.\ it would be a mistake to apply \ex{escape-uri} to
\begin{verbatim}
//lcs.mit.edu:8001/foo/bar.html
\end{verbatim}
%
because the sla\-shes and co\-lons would be escaped.
\defun{split-uri}{uri start end} {list}
\begin{desc}
This procedure splits \var{uri} at slashes. Only the substring given
with \var{start} (inclusive) and \var{end} (exclusive) as indices is
considered. \var{start} and $\var{end} - 1$ have to be within the
range of \var{uri}. Otherwise an \ex{index-out-of-range} exception
will be raised.
Example: \codex{(split-uri "foo/bar/colon" 4 11)} returns
\codex{("bar" "col")}
\end{desc}
\defun{uri-path->uri}{path}{string}
\begin{desc}
This procedure generates a path out of a URI path list by inserting
slashes between the elements of \var{plist}.
\end{desc}
%
If you want to use the resulting string for further operation, you
should escape the elements of \var{plist} in case they contain
slashes, like so:
%
\begin{verbatim}
(uri-path->uri (map escape-uri pathlist))
\end{verbatim}
\defun{simplify-uri-path}{path}{list}
\begin{desc}
This procedure simplifies a URI path. It removes \verb|"."| and
\verb|"/.."| entries from path, and removes parts before a root.
The result is a list, or \sharpf{} if the path tries to back up past
root.
\end{desc}
%
According to RFC~2396, relative paths are considered not to start with
\verb|/|. They are appended to a base URL path and then simplified.
So before you start to simplify a URL try to find out if it is a
relative path (i.e. it does not start with a \verb|/|).
Examples:
%
\begin{alltt}
(simplify-uri-path (split-uri "/foo/bar/baz/.." 0 15))
\(\Rightarrow\) ("" "foo" "bar")
(simplify-uri-path (split-uri "foo/bar/baz/../../.." 0 20))
\(\Rightarrow\) ()
(simplify-uri-path (split-uri "/foo/../.." 0 10))
\(\Rightarrow\) #f
(simplify-uri-path (split-uri "foo/bar//" 0 9))
\(\Rightarrow\) ("")
(simplify-uri-path (split-uri "foo/bar/" 0 8))
\(\Rightarrow\) ("")
(simplify-uri-path (split-uri "/foo/bar//baz/../.." 0 19))
\(\Rightarrow\) #f
\end{alltt}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

113
doc/latex/url.tex
View File

@ -1,113 +0,0 @@
\chapter{Parsing and Processing URLs}\label{cha:url}
%
This modules contains procedures to parse and unparse URLs. Until
now, only the parsing of HTTP URLs is implemented.
\section{Server Records}
A \textit{server} value describes path prefixes of the form
\var{user}:\var{password}@\var{host}:\var{port}. These are
frequently used as the initial prefix of URLs describing Internet
resources.
\defun{make-server}{user password host port}{server}
\defunx{server?}{thing}{boolean}
\defunx{server-user}{server}{string-or-\sharpf}
\defunx{server-password}{server}{string-or-\sharpf}
\defunx{server-host}{server}{string-or-\sharpf}
\defunx{server-port}{server}{string-or-\sharpf}
\begin{desc}
\ex{Make-server} creates a new server record. Each slot is a
decoded string or \sharpf. (\var{Port} is also a string.)
\ex{server?} is the corresponding predicate, \ex{server-user},
\ex{server-password}, \ex{server-host} and \ex{server-port}
are the correspondig selectors.
\end{desc}
\defun{parse-server}{path default}{server}
\defunx{server->string}{server}{string}
\begin{desc}
\ex{Parse-server} parses a URI path \var{path} (a list representing
a path, not a string) into a server value. Default values are taken
from the server \var{default} except for the host. The values
are unescaped and stored into a server record that is returned.
\ex{Fatal-syntax-error} is called, if the specified path has no
initial to slashes (i.e., it starts with `//\ldots').
\ex{server->string} just does the inverse job: it unparses
\var{server} into a string. The elements of the record
are escaped before they are put together.
Example:
\begin{alltt}
> (define default (make-server "andreas" "se ret" "www.sf.net" "80"))
> (server->string default)
"andreas:se\%20ret@www.sf.net:80"
> (parse-server '("" "" "foo\%20bar@www.scsh.net" "docu" "index.html")
default)
'#{server}
> (server->string ##)
"foo\%20bar:se\%20ret@www.scsh.net:80"
\end{alltt}
%
For details about escaping and unescaping see Chapter~\ref{cha:uri}.
\end{desc}
\section{HTTP URLs}
\defun{make-http-url}{server path search frag-id}{http-url}
\defunx{http-url?}{thing}{boolean}
\defunx{http-url-server}{http-url}{server}
\defunx{http-url-path}{http-url}{list}
\defunx{http-url-search}{http-url}{string-or-\sharpf}
\defunx{http-url-frag-ment-identifier}{http-url}{string-or-\sharpf}
%
\begin{desc}
\ex{Make-http-url} creates a new \ex{httpd-url} record.
\var{Server} is a record, containing the initial part of the address
(like \ex{anonymous@clark.lcs.mit.edu:80}). \var{Path} contains the
URL's URI path ( a list). These elements are in raw, unescaped
format. To convert them back to a string, use
\ex{(uri-path-list->path (map escape-uri pathlist))}. \var{Search}
and \var{frag-id} are the last two parts of the URL. (See
Chapter~\ref{cha:uri} about parts of an URI.)
\ex{Http-url?} is the predicate for HTTP URL values, and
\ex{http-url-server}, \ex{http-url-path}, \ex{http-url-search} and
\ex{http-url-fragment-identifier} are the corresponding selectors.
\end{desc}
\defun{parse-http-url}{path search frag-id}{http-url}
\begin{defundescx}{http-url->string}{http-url}{string}
This constructs an HTTP URL record from a URI path (a list of path
components), a search, and a frag-id component.
\ex{Http-url->string} just does the inverse job. It converts an
HTTP URL record into a string.
\end{defundescx}
%
Note: The URI parser \ex{parse-uri} maps a string to four parts:
\var{scheme}, \var{path}, \var{search} and \var{frag-id} (see
Section~\ref{proc:parse-uri} for details). If \var{scheme} is
\ex{http}, then the other three parts can be passed to
\ex{parse-http-url}, which parses them into a \ex{http-url} record.
All strings come back from the URI parser encoded. \var{Search} and
\var{frag-id} are left that way; this parser decodes the path
elements. The first two list elements of the path indicating the
leading double-slash are omitted.
The following procedure combines the jobs of \ex{parse-uri} and
\ex{parse-http-url}:
\defun{parse-http-url-string}{string}{http-url}
\begin{desc}
This parses an HTTP URL and returns the corresponding URL value; it
calls \ex{fatal-syntax-error} if the URL string doesn't have an
\ex{http} scheme.
\end{desc}
%%% Local Variables:
%%% mode: latex
%%% TeX-master: "man"
%%% End:

1324
scheme/ftpd/ftpd.scm
View File

File diff suppressed because it is too large Load Diff

76
scheme/httpd/access-control.scm
View File

@ -1,76 +0,0 @@
;;; http server in the Scheme Shell -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1996 by Mike Sperber. <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; This code is very rudimentary at the moment and up for some expansion.
;;; Right now, it is primarily useful for running the server through a
;;; web accelerator
(define (access-denier . hosts)
(lambda (info)
(and (any (lambda (host)
(host-matches? info host))
hosts)
'deny)))
(define (access-allower . hosts)
(lambda (info)
(and (any (lambda (host)
(host-matches? info host))
hosts)
'allow)))
(define (access-controller . controls)
(lambda (info)
(let loop ((controls controls))
(and (pair? controls)
(or ((car controls) info)
(loop (cdr controls)))))))
(define (access-controlled-handler control ph)
(lambda (path req)
(if (eq?
(control (host-info (socket-remote-address (request-socket req))))
'deny)
(http-error (status-code forbidden) req)
(ph path req))))
(define (address->list address)
(list (arithmetic-shift (bitwise-and address #xff000000) -24)
(arithmetic-shift (bitwise-and address #xff0000) -16)
(arithmetic-shift (bitwise-and address #xff00) -8)
(bitwise-and address #xff)))
(define (host-matches? info host)
(cond
((list? host)
(let ((len (length host)))
(any (lambda (address)
(equal? (take len (address->list address)) host))
(host-info:addresses info))))
(else ; (string? host)
(any (lambda (name)
(string-match host (string-map char-downcase name)))
(cons (host-info:name info)
(host-info:aliases info))))))
(define normalize-host
(let ((split (infix-splitter (make-regexp "\\.")))
(number (make-regexp "[0-9]+")))
(lambda (host)
(let ((components (split host)))
(if (every (lambda (component)
(regexp-exec number component))
components)
(map string->number components)
host)))))
(define (take n l)
(let loop ((n n) (l l) (r '()))
(if (zero? n)
(reverse r)
(loop (- n 1) (cdr l) (cons (car l) r)))))

302
scheme/httpd/cgi-server.scm
View File

@ -1,302 +0,0 @@
;;; Server support for NCSA's WWW Common Gateway Interface -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
;;; PROBLEMS:
;;; - The handlers could be made -- closed over their parameters
;;; (e.g., root vars, etc.)
;;; This code provides a request handler for the HTTP server that implements
;;; a CGI interface to external programs for doing HTTP transactions.
;;; About HTML forms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This info is in fact independent of CGI, but important to know about,
;;; as many CGI scripts are written for responding to forms-entry in
;;; HTML browsers.
;;;
;;; The form's field data are turned into a single string, of the form
;;; name=val&name=val
;;; where the <name> and <val> parts are URI encoded to hide their
;;; &, =, and + chars, among other things. After URI encoding, the
;;; space chars are converted to + chars, just for fun. It is important
;;; to encode the spaces this way, because the perfectly general %xx escape
;;; mechanism might be insufficiently confusing. This variant encoding is
;;; called "form-url encoding."
;;;
;;; If the form's method is POST,
;;; Browser sends the form's field data in the entity block, e.g.,
;;; "button=on&ans=yes". The request's Content-type: is application/
;;; x-www-form-urlencoded, and the request's Content-length: is the
;;; number of bytes in the form data.
;;;
;;; If the form's method is GET,
;;; Browser sends the form's field data in the URL's <search> part.
;;; (So the server will pass to the CGI script as $QUERY_STRING,
;;; and perhaps also on in argv[]).
;;;
;;; In either case, the data is "form-url encoded" (as described above).
;;; ISINDEX queries:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (Likewise for ISINDEX URL queries from browsers.)
;;; Browser url-form encodes the query (see above), which then becomes the
;;; ?<search> part of the URI. (Hence the CGI script will split the individual
;;; fields into argv[].)
;;; CGI interface:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
;;; - If it contains no raw "=" chars, it is split at "+" chars. The
;;; substrings are URI decoded, and become the elts of argv[].
;;; - The CGI script is run with stdin hooked up to the socket. If it's going
;;; to read the entity, it should read $CONTENT_LENGTH bytes worth.
;;; - A bunch of env vars are set; see below.
;;; - If the script begins with "nph-" its output is the entire response.
;;; Otherwise, it replies to the server, we peel off a little header
;;; that is used to construct the real header for the response.
;;; See the "spec" for further details. (URL above).
;;;
;;; The "spec" also talks about PUT, but when I tried this on a dummy script,
;;; the NSCA httpd server generated buggy output. So I am only implementing
;;; the POST and GET ops; any other op generates a "405 Method not allowed"
;;; response.
;;; Parameters
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; path for scripts
(define cgi-default-bin-path "/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin")
;;; The request handler for CGI scripts. (car path) is the script to run.
;;; cgi-bin-path is used, if PATH-variable isn't defined
(define (cgi-handler bin-dir . maybe-cgi-bin-path)
(let-optionals
maybe-cgi-bin-path
((cgi-bin-path cgi-default-bin-path))
(let ((request-invariant-cgi-env ; environment variables that never change
`(("PATH" . ,cgi-bin-path)
("SERVER_SOFTWARE" . ,sunet-version-identifier)
("SERVER_NAME" . ,(host-info:name (host-info (system-name))))
("GATEWAY_INTERFACE" . "CGI/1.1"))))
(lambda (path req)
(if (pair? path) ; Got to have at least one elt.
(compute-cgi path req bin-dir request-invariant-cgi-env)
(make-error-response (status-code bad-request) req "Empty CGI script"))))))
(define (compute-cgi path req bin-dir request-invariant-cgi-env)
(let* ((prog (car path))
(filename (or (dotdot-check bin-dir (list prog))
(http-error (status-code bad-request) req
"CGI scripts may not contain \"..\" elements.")))
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
; why did we had (string-suffix? "-nph" prog) here?
(search (http-url-search (request-url req))) ; Compute the
(argv (if (and search (not (string-index search #\=))) ; argv list.
(split-and-decode-search-spec search)
'()))
(env (cgi-env req bin-dir (cdr path) request-invariant-cgi-env))
(doit (lambda ()
(dup->inport (socket:inport (request-socket req)) 0)
(dup->outport (current-output-port) 1)
(dup 1 2)
(apply exec/env filename env argv))))
(http-syslog (syslog-level debug) "[cgi-server] search: ~s, argv: ~s~%" search argv)
(let ((request-method (request-method req)))
(cond
((or (string=? request-method "GET")
(string=? request-method "POST")) ; Could do others also.
(case (file-not-executable? filename)
((search-denied permission)
(make-error-response (status-code forbidden) req
"Permission denied."))
((no-directory nonexistent)
(make-error-response (status-code not-found) req
"File or directory doesn't exist."))
(else
(if nph?
(cgi-make-nph-response (run/port* doit))
(cgi-make-response (run/port* doit) path req)))))
(else
(make-error-response (status-code method-not-allowed) req request-method))))))
(define (split-and-decode-search-spec s)
(let recur ((i 0))
(cond
((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
(recur (+ j 1)))))
(else (list (unescape-uri s i (string-length s)))))))
;;; Compute the CGI scripts' process environment by adding the standard CGI
;;; environment var bindings to the current process env -- return result
;;; as an alist.
;;;
;;; You are also supposed to add the headers as env vars in a particular
;;; format, but are allowed to bag it if the environment var storage
;;; requirements might overload the OS. I don't know what you can rely upon
;;; in Unix, so I am just bagging it, period.
;;;
;;; Suppose the URL is
;;; //machine/cgi-bin/test-script/foo/bar?quux%20a+b=c
;;; then:
;; PATH_INFO -- extra info after the script-name path prefix. "/foo/bar"
;;; PATH_TRANSLATED -- non-virtual version of above. "/u/Web/foo/bar/"
;;; SCRIPT_NAME virtual path to script "/cgi-bin/test-script"
;;; QUERY_STRING -- not decoded "quux%20a+b=c"
;;; The first three of these vars are *not* encoded, so information is lost
;;; if the URL's path elements contain encoded /'s (%2F). CGI loses.
(define (cgi-env req bin-dir path-suffix request-invariant-cgi-env)
(let* ((sock (request-socket req))
(raddr (socket-remote-address sock))
(headers (request-headers req))
;; Compute the $PATH_INFO and $PATH_TRANSLATED strings.
(path-info (uri-path->uri path-suffix)) ; No encode or .. check.
(path-translated (path-list->file-name path-info bin-dir))
;; Compute the $SCRIPT_PATH string.
(url-path (http-url-path (request-url req)))
(script-path (take (- (length url-path) (length path-suffix))
url-path))
(script-name (uri-path->uri script-path)))
(receive (rhost rport)
(socket-address->internet-address raddr)
(receive (lhost lport)
(socket-address->internet-address (socket-local-address sock))
`(("SERVER_PROTOCOL" . ,(version->string (request-version req)))
("SERVER_PORT" . ,(number->string lport))
("REQUEST_METHOD" . ,(request-method req))
("PATH_INFO" . ,path-info)
("PATH_TRANSLATED" . ,path-translated)
("SCRIPT_NAME" . ,script-name)
("REMOTE_ADDR" . ,(format-internet-host-address rhost))
;; ("AUTH_TYPE" . xx) ; Random authentication
;; ("REMOTE_USER" . xx) ; features I don't understand.
;; ("REMOTE_IDENT" . xx)
,@request-invariant-cgi-env ; Stuff that never changes (see cgi-handler).
,@(cond ((http-url-search (request-url req)) =>
(lambda (srch) `(("QUERY_STRING" . ,srch))))
(else '()))
,@(cond ((get-header headers 'content-type) =>
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
(else '()))
,@(cond ((get-header headers 'content-length) =>
(lambda (cl) ; Skip initial whitespace (& other non-digits).
(let ((first-digit (string-index cl char-set:digit))
(cl-len (string-length cl)))
(if first-digit
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
(http-error (status-code bad-request) req
"Illegal `Content-length:' header.")))))
(else '()))
. ,(env->alist))))))
(define (take n lis)
(if (zero? n) '()
(cons (car lis) (take (- n 1) (cdr lis)))))
(define (drop n lis)
(if (zero? n) lis
(drop (- n 1) (cdr lis))))
;;; Script's output for request REQ is available on SCRIPT-PORT.
;;; The script isn't an "nph-" script, so we read the response, and mutate
;;; it into a real HTTP response, which we then send back to the HTTP client.
(define (cgi-make-response script-port path req)
(let* ((headers (read-rfc822-headers script-port))
(ctype (get-header headers 'content-type))
(loc (get-header headers 'location))
(stat (extract-status-code-and-text (get-header headers 'status)
req))
(extra-headers (delete-headers (delete-headers (delete-headers headers
'content-type)
'location)
'status)))
(http-syslog (syslog-level debug) "[cgi-server] headers: ~s~%" headers)
(http-syslog (syslog-level debug) "[cgi-server] request-method=~a~%"
(request-method req))
(if loc
(if (uri-has-protocol? (string-trim loc))
(make-error-response (status-code moved-perm) req
loc loc)
(make-redirect-response (string-trim loc)))
;; Send the response header back to the client
(make-response ;code message seconds mime extras body
(number->status-code (car stat))
(cdr stat) ; text
(time)
ctype
extra-headers
(make-writer-body
(lambda (out options)
(copy-inport->outport script-port out)
(close-input-port script-port)))))))
(define (get-header headers tag)
(cond
((assq tag headers) => cdr)
(else
(http-error (status-code bad-gateway) #f
(string-append "CGI script didn't generate "
(symbol->string tag)
" header")))))
(define (delete-headers headers tag)
(alist-delete tag headers))
(define (cgi-make-nph-response script-port)
(make-nph-response
(make-writer-body (lambda (out options)
(copy-inport->outport script-port out)))))
(define (uri-has-protocol? loc)
(receive (proto path search frag)
(parse-uri loc)
(if proto #t #f)))
(define (extract-status-code-and-text status req)
(with-fatal-error-handler*
(lambda (c d)
(http-error (status-code bad-gateway) req
"CGI script generated an invalid status header."
status c))
(lambda ()
(let ((status (string-trim status)))
(cons (string->number (substring status 0 3)) ; number
(substring/shared status 4)))))) ; text

366
scheme/httpd/core.scm
View File

@ -1,366 +0,0 @@
;;; http server in the Scheme Shell -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 2000-2002 by Martin Gasbichler.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; This file implements the core of an HTTP server: code to establish
;;; net connections, read and parse requests, and handler errors.
;;; It does not have the code to actually handle requests. That's up
;;; to other modules, and could vary from server to server. To build
;;; a complete server, you need to define request handlers (see below) --
;;; they determine how requests are to be handled.
;;;
;;; The RFC detailing the HTTP 1.0 protocol, RFC 1945, can be found at
;;; http://www.w3.org/Protocols/rfc1945/rfc1945
(define server/protocol "HTTP/1.0")
(define (httpd options)
(let ((port (httpd-options-port options))
(root-dir (httpd-options-root-directory options))
(rate-limiter
(cond
((httpd-options-simultaneous-requests options)
=> make-rate-limiter)
(else #f))))
(let-thread-fluid
logging
(make-logging)
(lambda ()
(init-http-log! options)
(with-syslog-destination
"httpd" #f #f #f
(lambda ()
(with-cwd
root-dir
(bind-listen-accept-loop
protocol-family/internet
;; Why is the output socket unbuffered? So that if the client
;; closes the connection, we won't lose when we try to close the
;; socket by trying to flush the output buffer.
(lambda (sock addr)
(if rate-limiter
(begin
(rate-limit-block rate-limiter)
(rate-limit-open rate-limiter)))
(with-fatal-error-handler
(lambda (c decline)
(http-syslog (syslog-level notice) "error during connection negotiation~%")
(if rate-limiter
(rate-limit-close rate-limiter)))
(call-with-values
(lambda ()
(socket-address->internet-address (socket-remote-address sock)))
(lambda (host-address service-port)
(if (and rate-limiter (http-syslog?))
(http-syslog (syslog-level info) "<~a>~a: concurrent request #~a~%"
(pid)
(format-internet-host-address host-address)
(rate-limiter-current-requests rate-limiter)))
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
(fork-thread
(lambda ()
(set-port-buffering (socket:inport sock) bufpol/none)
(process-toplevel-request sock host-address options)
(if (http-syslog?)
(http-syslog (syslog-level debug) "<~a>~a [closing]~%"
(pid)
(format-internet-host-address host-address)))
(with-fatal-error-handler
(lambda (c decline)
(if (http-syslog?)
(http-syslog (syslog-level notice) "<~a>~a [error closing (~a)]~%"
(pid)
(format-internet-host-address host-address)
c)))
(close-socket sock))
(if rate-limiter
(rate-limit-close rate-limiter))
(if (http-syslog?)
(http-syslog (syslog-level info) "<~a>~a [closed]~%"
(pid)
(format-internet-host-address host-address)))))))))
port))))))))
;;; Top-level http request processor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read, parse, and handle a single http request. The only thing that makes
;;; this complicated is handling errors -- as a server, we can't just let the
;;; standard error handlers toss us into a breakpoint. We have to catch the
;;; error, send an error response back to the client if we can, and then keep
;;; on trucking. This means using the S48's condition system to catch and
;;; handle the various errors, which introduces a major point of R5RS
;;; incompatibiliy -- R5RS has no exception system. So if you were to port
;;; this code to some other Scheme, you'd really have to sit down and think
;;; about this issue for a minute.
(define (process-toplevel-request sock host-address options)
;; This top-level error-handler catches *all* uncaught errors and warnings.
;; If the error condition is a reportable HTTP error, we send a response back
;; to the client. In any event, we abort the transaction, and return from
;; PROCESS-TOPLEVEL-REQUEST.
;;
;; We *oughta* map non-http-errors into replies anyway.
(with-fatal-error-handler*
(lambda (c decline)
(http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
(pid)
(format-internet-host-address host-address)
c)
(with-fatal-error-handler*
(lambda (c decline)
(http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%"
(pid)
(format-internet-host-address host-address)
c))
(lambda ()
(shutdown-socket sock shutdown/sends+receives)
(http-syslog (syslog-level info) "<~a>~a [shut down]~%"
(pid)
(format-internet-host-address host-address)))))
(lambda ()
(call-with-values
(lambda ()
(with-fatal-error-handler*
(lambda (c decline)
(http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
(pid)
(format-internet-host-address host-address)
c)
(cond
((http-error? c)
(apply (lambda (status-code req . args)
(values req
(apply make-error-response
status-code req
args)))
(condition-stuff c)))
((fatal-syntax-error? c)
(values #f
(apply make-error-response (status-code bad-request)
#f ; No request yet.
"Request parsing error -- report to client maintainer."
(condition-stuff c))))
((not (and (exception? c)
(eq? (exception-reason c)
(enum exception os-error))))
;; try to send bug report to client
(values #f
(apply make-error-response (status-code internal-error)
#f ; don't know
"Internal error occured while processing request"
c)))
(else
(decline))))
(lambda ()
(let ((initial-req (parse-http-request sock options)))
(let redirect-loop ((req initial-req))
(let ((response ((httpd-options-request-handler options)
(http-url-path (request-url req))
req)))
(cond
((nph-response? response)
(values req response))
((eq? (response-code response) (status-code redirect))
(redirect-loop (redirect-request req response sock options)))
(else
(values req response)))))))))
(lambda (req response)
(send-http-response req response
(socket:inport sock)
(socket:outport sock)
options)
)))))
(define (redirect-request req response socket options)
(let* ((new-location-uri (redirect-body-location (response-body response)))
(url (with-fatal-error-handler*
(lambda (c decline)
(if (fatal-syntax-error? c)
(http-error (status-code internal-error) req
(format #f "Bad redirection out from CGI program: ~%~a"
(cdr c)))
(decline c)))
(lambda ()
;; (future) NOTE: With this, a redirection may change the
;; protocol in use (currently, the server only supports one of
;; it). This might be inapplicable.
(parse-http-servers-url-fragment new-location-uri socket options)))))
(make-request "GET"
new-location-uri
url
(request-version req) ; did not change
'() ; no rfc822 headers
(request-socket req))))
;;;; HTTP request parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; This code provides procedures to read requests from an input
;;;; port.
;;; Read and parse an http request from INPORT.
;;;
;;; Note: this parser parses the URI into an http URL record. If the URI
;;; isn't an http URL, the parser fails. This may not be right. There's
;;; nothing in the http protocol to prevent you from passing a non-http
;;; URI -- what this would mean, however, is not clear. Like so much of
;;; the Web, the protocols are redundant, underconstrained, and ill-specified.
(define (parse-http-request sock options)
(let ((line (read-crlf-line (socket:inport sock))))
;; Blat out some logging info.
(if (http-syslog?)
(call-with-values
(lambda ()
(socket-address->internet-address (socket-remote-address sock)))
(lambda (host-address service-port)
(http-syslog (syslog-level info) "<~a>~a: ~a~%"
(pid)
(format-internet-host-address host-address)
line))))
(if (eof-object? line)
(fatal-syntax-error "EOF while parsing request.")
(let* ((elts (string->words line)) ; Split at white-space.
(version (case (length elts)
((2) '(0 . 9))
((3) (parse-http-version (caddr elts)))
(else (fatal-syntax-error "Bad HTTP version.")))))
(let* ((meth (car elts))
(uri-string (cadr elts))
(url (parse-http-servers-url-fragment uri-string sock options))
(headers (if (equal? version '(0 . 9))
'()
(read-rfc822-headers (socket:inport sock)))))
(make-request meth uri-string url version headers sock))))))
;;; Parse the URL, but if it begins without the "http://host:port"
;;; prefix, interpolate one from SOCKET. It would be sleazier but
;;; faster if we just computed the default host and port at
;;; server-startup time, instead of on every request.
;;; REDIRECT-REQUEST relys on that nothing is read out from SOCKET.
(define (parse-http-servers-url-fragment uri-string socket options)
(receive (scheme path search frag-id) (parse-uri uri-string)
(if frag-id ; Can't have a #frag part.
(fatal-syntax-error "HTTP URL contains illegal #<fragment> suffix."
uri-string)
(if scheme
(if (string-ci=? scheme "http") ; Better be an http url.
(parse-http-url path search #f)
(fatal-syntax-error "Non-HTTP URL" uri-string))
;; Interpolate the server struct from our net connection.
(if (and (pair? path) (string=? (car path) ""))
(let* ((addr (socket-local-address socket))
(local-name (or (httpd-options-fqdn options)
(socket-address->fqdn addr #t)))
(portnum (or (httpd-options-reported-port options)
(my-reported-port addr))))
(make-http-url (make-server #f #f
local-name
(number->string portnum))
(map unescape-uri (cdr path)) ; Skip initial /.
search
#f))
(fatal-syntax-error "Path fragment must begin with slash"
uri-string))))))
(define parse-http-version
(let ((re (make-regexp "^HTTP/([0-9]+)\\.([0-9]+)$"))
(lose (lambda (s) (fatal-syntax-error "Bad HTTP version" s))))
(lambda (vstring)
(let ((m (regexp-exec re vstring)))
(if m
(cons (or (string->number (match:substring m 1) 10) (lose vstring))
(or (string->number (match:substring m 2) 10) (lose vstring)))
(lose vstring))))))
;;; Split string into a list of whitespace-separated strings.
;;; This could have been trivially defined in scsh as (field-splitter " \t\n")
;;; but I hand-coded it because it's short, and I didn't want invoke the
;;; regexp machinery for something so simple.
(define non-whitespace (char-set-complement char-set:whitespace))
(define (string->words s)
(let recur ((start 0))
(cond ((string-index s non-whitespace start) =>
(lambda (start)
(cond ((string-index s char-set:whitespace start) =>
(lambda (end)
(cons (substring s start end)
(recur end))))
(else (list (substring s start (string-length s)))))))
(else '()))))
(define (send-http-headers response port)
(display server/protocol port)
(write-char #\space port)
(display (status-code-number (response-code response)) port)
(write-char #\space port)
(display (or (response-message response)
(status-code-message (response-code response)))
port)
(write-crlf port)
(send-http-header-fields
(list (cons 'server (string-append "Scheme Untergrund " sunet-version-identifier))
(cons 'content-type (response-mime response))
(cons 'date (rfc822-time->string (response-seconds response))))
port)
(send-http-header-fields (response-extras response) port)
(write-crlf port))
(define (send-http-response request response input-port output-port options)
(cond
((not request)
;; We have a bad request error. Try to report this headerless.
(display-http-body (response-body response) input-port output-port options)
;; no CLF-logging
)
((nph-response? response)
(display-http-body (nph-response-body response) input-port output-port options)
(http-log request (status-code ok))); guess the status code
(else
(if (not (v0.9-request? request))
(send-http-headers response output-port))
(if (not (string=? (request-method request) "HEAD"))
(display-http-body (response-body response) input-port output-port options))
(http-log request (response-code response)))))
(define (send-http-header-fields headers port)
(for-each (lambda (pair)
(display (car pair) port)
(write-char #\: port)
(display (cdr pair) port)
(write-crlf port))
headers))
(define (my-reported-port addr)
(receive (ip-addr portnum) (socket-address->internet-address addr)
portnum))

41
scheme/httpd/error.scm
View File

@ -1,41 +0,0 @@
;;; Error stuff for the http server. -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; An http error condition is a data structure with the following pieces:
;;; (error-code request message . irritants)
;;; You recognise one with HTTP-ERROR?, and retrieve the pieces with
;;; CONDITION-STUFF.
;;;
;;; HTTP error condition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define a sub-type of the S48 error condition, the HTTP error condition.
;;; An HTTP error is one that corresponds to one of the HTTP error response
;;; codes, so you can reliably use an HTTP error condition to construct an
;;; error response message to send back to the HTTP client.
(define-condition-type 'http-error '(error))
(define http-error? (condition-predicate 'http-error))
(define (http-error status-code req . args)
(apply signal 'http-error status-code req args))
;;; Syntax error condition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Scheme 48 has a "syntax error" error condition, but it isn't an error
;;; condition! It's a warning condition. I don't understand this.
;;; We define a *fatal* syntax error here for the parsers to use.
(define-condition-type 'fatal-syntax-error '(error))
(define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
(define (fatal-syntax-error msg . irritants)
(apply signal 'fatal-syntax-error msg irritants))

496
scheme/httpd/file-dir-handler.scm
View File

@ -1,496 +0,0 @@
;;; http server in the Scheme Shell -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define server/buffer-size 8192) ; WTF
;;; (home-dir-handler user-public-dir) -> handler
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Return a request handler that looks things up in a specific directory
;;; in the user's home directory. If ph = (home-dir-handler "public_html")
;;; then ph is a request handler that serves files out of peoples' public_html
;;; subdirectory. So
;;; (ph '("shivers" "hk.html") req)
;;; will serve the file
;;; ~shivers/public_html/hk.html
;;; The request handler treats the URL path as (<user> . <file-path>),
;;; serving
;;; ~<user>/<user-public-dir>/<file-path>
(define (home-dir-handler user-public-dir)
(lambda (path req)
(if (null? path)
(make-error-response (status-code bad-request)
req
"Path contains no home directory.")
(make-rooted-file-path-response (string-append (http-homedir (car path) req)
"/"
user-public-dir)
(cdr path)
file-serve-response
req))))
;;; (tilde-home-dir-handler user-public-dir default-request-handler)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"),
;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
;;; default handler.
(define (tilde-home-dir? path req)
(and (not (null? path))
(let ((head (car path))) ; home-directory path?
(and (> (string-length head) 0)
(char=? (string-ref head 0) #\~)))))
(define (tilde-home-dir-handler user-public-dir default-handler)
(make-predicate-handler
tilde-home-dir?
(lambda (path req)
(let* ((tilde-home (car path)) ; Yes.
(slen (string-length tilde-home))
(subdir (string-append
(http-homedir (substring tilde-home 1 slen) req)
"/"
user-public-dir)))
(make-rooted-file-path-response subdir (cdr path) file-serve-response req)))
default-handler))
;;; Make a handler that serves files relative to a particular root
;;; in the file system. You may follow symlinks, but you can't back up
;;; past ROOT with ..'s.
(define (rooted-file-handler root)
(lambda (path req)
(make-rooted-file-path-response root path file-serve-response req)))
;;; Dito, but also serve directory indices for directories without
;;; index.html.
(define (rooted-file-or-directory-handler root)
(lambda (path req)
(make-rooted-file-path-response root path
file-serve-and-dir-response
req)))
;;;; Support procs for the path handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Do a request for a file. The file-name is determined by appending the
;;; the FILE-PATH list the string ROOT. E.g., if
;;; ROOT = "/usr/shivers" FILE-PATH = ("a" "b" "c" "foo.html")
;;; then we serve file
;;; /usr/shivers/a/b/c/foo.html
;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
;;; (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path
;;; sequences are processed away by the browser when the URI is converted
;;; to an absolute URI before it is sent off to the server.)
;;; It is possible to sneak a .. past this kind of front-end resolving by
;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
;;; this, MAKE-ROOTED-FILE-PATH-RESPONSE will catch it, and abort the transaction.
;;; So you cannot make the reference back up past ROOT. E.g., this is
;;; not allowed:
;;; FILE-PATH = ("a" "../.." "c" "foo.html")
;;;
;;; Only GET and HEAD ops are provided.
;;; The URL's <search> component must be #f.
;;; The file is served if the server has read or stat(2) access to it,
;;; respectively. If the server is run as root, this might be a problem.
;;;
;;; FILE-SERVE is a procedure which gets passed the file name, the
;;; path, and the HTTP request to serve the file propert after the
;;; security checks. Look in ROOTED-FILE-HANDLER and
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
(define (make-rooted-file-path-response root file-path file-serve-response req)
(if (http-url-search (request-url req))
(make-error-response (status-code bad-request) req
"Indexed search not provided for this URL.")
(cond ((dotdot-check root file-path) =>
(lambda (fname)
(file-serve-response fname file-path req)))
(else
(make-error-response (status-code bad-request) req
"URL contains unresolvable ..'s.")))))
;; Just (file-info fname) with error handling.
(define (stat-carefully fname req)
(with-errno-handler
((errno packet)
((errno/noent)
(http-error (status-code not-found) req))
((errno/acces)
(http-error (status-code forbidden) req)))
(file-info fname #t)))
;;; A basic file request handler -- ship the dude the file. No fancy path
;;; checking. That has presumably been taken care of. This handler only
;;; takes care of GET and HEAD methods.
(define (file-serve-or-dir-response fname file-path req directory-serve-response)
(if (file-name-directory? fname) ; Simple index generation.
(directory-serve-response fname file-path req)
(let ((request-method (request-method req)))
(cond
((or (string=? request-method "GET")
(string=? request-method "HEAD")) ; Absolutely.
(let ((info (stat-carefully fname req)))
(case (file-info:type info)
((regular fifo socket)
(send-file-response fname info req))
((directory) ; Send back a redirection "foo" -> "foo/"
(make-error-response
(status-code moved-perm) req
(string-append (request-uri req) "/")
(string-append (http-url->string (request-url req))
"/")))
(else (make-error-response (status-code forbidden) req)))))
(else
(make-error-response (status-code method-not-allowed) req
request-method))))))
(define (directory-index-serve-response fname file-path req)
(file-serve-response (string-append fname "index.html") file-path req))
(define (file-serve-response fname file-path req)
(file-serve-or-dir-response fname file-path req
directory-index-serve-response))
(define (tag->alt tag)
(case tag
((directory) "[DIR]")
((text) "[TXT]")
((doc) "[DOC]")
((image) "[IMG]")
((movie) "[MVI]")
((audio) "[AU ]")
((archive) "[TAR]")
((compressed) "[ZIP]")
((uu) "[UU ]")
((binhex) "[HQX]")
((binary) "[BIN]")
(else "[ ]")))
;; These icons can, for example, be found in the cern-httpd-3.0
;; distribution at http://www.w3.org/pub/WWW/Daemon/
(define (tag->icon tag)
(case tag
((directory) "directory.xbm")
((text) "text.xbm")
((doc) "doc.xbm")
((image) "image.xbm")
((movie) "movie.xbm")
((audio) "sound.xbm")
((archive) "tar.xbm")
((compressed) "compressed.xbm")
((uu) "uu.xbm")
((binhex) "binhex.xbm")
((binary) "binary.xbm")
((blank) "blank.xbm")
((back) "back.xbm")
(else "unknown.xbm")))
(define (file-extension->tag fname)
(let ((ext (file-name-extension fname)))
(cond
((string-ci=? ext ".txt") 'text)
((or (string-ci=? ext ".doc")
(string-ci=? ext ".htm")
(string-ci=? ext ".html")
(string-ci=? ext ".rtf")
(string-ci=? ext ".pdf")
(string-ci=? ext ".dvi")
(string-ci=? ext ".ps")
(string-ci=? ext ".tex")) 'doc)
((or (string-ci=? ext ".bmp")
(string-ci=? ext ".gif")
(string-ci=? ext ".png")
(string-ci=? ext ".jpg")
(string-ci=? ext ".jpeg")
(string-ci=? ext ".tiff")
(string-ci=? ext ".tif")) 'image)
((or (string-ci=? ext ".mpeg")
(string-ci=? ext ".mpg")) 'movie)
((or (string-ci=? ext ".au")
(string-ci=? ext ".snd")
(string-ci=? ext ".mp3")
(string-ci=? ext ".wav")) 'audio)
((or (string-ci=? ext ".tar")
(string-ci=? ext ".zip")
(string-ci=? ext ".zoo")) 'archive)
((or (string-ci=? ext ".gz")
(string-ci=? ext ".Z")
(string-ci=? ext ".z")) 'compressed)
((string-ci=? ext ".uu") 'uu)
((string-ci=? ext ".hqx") 'binhex)
(else 'binary))))
(define (file-tag fname type)
(case type
((regular fifo socket) (file-extension->tag fname))
((directory) 'directory)
(else 'unknown)))
(define (time->directory-index-date-string time)
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
(define (read-max-lines fname max)
(call-with-input-file
fname
(lambda (port)
(let loop ((r "") (i max))
(if (zero? i)
r
(let ((line (read-line port)))
(if (eof-object? line)
r
(loop (string-append r " " line) (- i 1)))))))))
(define (string-cut s n)
(if (>= (string-length s) n)
(substring s 0 n)
s))
(define html-file-header
(let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
(lambda (fname n)
(let ((stuff (read-max-lines fname 10)))
(cond
((regexp-exec title-tag-regexp stuff)
=> (lambda (open-match)
(cond
((regexp-exec title-close-tag-regexp stuff
(match:end open-match 0))
=> (lambda (close-match)
(string-cut (substring stuff
(match:end open-match 0)
(match:start close-match 0))
n)))
(else (string-cut (substring stuff
(match:end open-match 0)
(string-length stuff))
n)))))
(else ""))))))
(define (file-documentation fname n)
(cond
((file-extension->content-type fname)
=> (lambda (content-type)
(if (and (string=? content-type "text/html" )
(file-readable? fname))
(html-file-header fname n)
"")))
(else "")))
(define (directory-index req dir icon-name port)
(define (pad-file-name file)
(write-string (make-string (max (- 21 (string-length file))
1)
#\space)
port))
(define (emit-file-name file)
(let ((l (string-length file)))
(if (<= l 20)
(emit-text file port)
(emit-text (substring file 0 20) port))))
(define (index-entry file)
(let* ((fname (directory-as-file-name (string-append dir file)))
(info (file-info fname #t))
(type (file-info:type info))
(size (file-info:size info))
(tag (file-tag file type)))
(emit-tag port 'img
(cons 'src (icon-name tag))
(cons 'alt (tag->alt tag)))
(with-tag port a ((href file))
(emit-file-name file))
(pad-file-name file)
(emit-text (time->directory-index-date-string (file-info:mtime info)) port)
(if size
(let* ((size-string
(string-append (number->string (quotient size 1024))
"K"))
(size-string
(if (<= (string-length size-string) 7)
size-string
(string-append (number->string (quotient size (* 1024 1024)))
"M")))
(size-string
(if (<= (string-length size-string) 8)
(string-append
(make-string (- 8 (string-length size-string)) #\space)
size-string)
size-string)))
(write-string size-string port))
(write-string (make-string 8 #\space) port))
(write-char #\space port)
(emit-text (file-documentation fname 24) port)
(write-crlf port)))
(let ((files (directory-files dir)))
(for-each index-entry files)
(length files)))
(define (directory-serve-response fname file-path req)
(let ((request-method (request-method req)))
(cond
((or (string=? request-method "GET")
(string=? request-method "HEAD"))
(if (not (eq? 'directory
(file-info:type (file-info fname #t))))
(make-error-response (status-code forbidden) req)
(make-response
(status-code ok)
#f
(time)
"text/html"
'()
(make-writer-body
(lambda (port options)
(let* ((icon-option (httpd-options-icon-name options))
(icon-name
(cond
((procedure? icon-option) icon-option)
((string? icon-option)
(lambda (tag)
(string-append icon-option (tag->icon tag))))
(else tag->icon))))
(with-tag port html ()
(let ((title (string-append "Index of /"
(string-join file-path "/"))))
(with-tag port head ()
(emit-title port title))
(with-tag port body ()
(emit-header port 1 title)
(with-tag port pre ()
(emit-tag port 'img
(cons 'src (icon-name 'blank))
(cons 'alt " "))
(write-string "Name " port)
(write-string "Last modified " port)
(write-string "Size " port)
(write-string "Description" port)
(emit-tag port 'hr)
(emit-tag port 'img
(cons 'src (icon-name 'back))
(cons 'alt "[UP ]"))
(if (not (null? file-path))
(begin
(with-tag port a ((href ".."))
(write-string "Parent directory" port))
(write-crlf port)))
(let ((n-files (directory-index req fname icon-name port)))
(emit-tag port 'hr)
(format port "~d files" n-files))))))))))))
(else
(make-error-response (status-code method-not-allowed) req
request-method)))))
(define (index-or-directory-serve-response fname file-path req)
(let ((index-fname (string-append fname "index.html")))
(if (file-readable? index-fname)
(file-serve-response index-fname file-path req)
(directory-serve-response fname file-path req))))
(define (file-serve-and-dir-response fname file-path req)
(file-serve-or-dir-response fname file-path req
index-or-directory-serve-response))
;;; Look up user's home directory, generating an HTTP error response if you lose.
(define (http-homedir username req)
(with-fatal-error-handler (lambda (c decline)
(apply http-error (status-code bad-request) req
"Couldn't find user's home directory."
(condition-stuff c)))
(home-dir username)))
(define (send-file-response filename info req)
(if (file-not-readable? filename) ; #### double stats are no good
(make-error-response (status-code not-found) req)
(receive (stripped-filename content-encoding)
(file-extension->content-encoding filename)
(make-response (status-code ok)
#f
(time)
(file-extension->content-type stripped-filename)
(append (if content-encoding
(cons 'content-encoding content-encoding)
'())
(list
(cons 'last-modified
(time->http-date-string
(file-info:mtime info)))
(cons 'content-length (file-info:size info))))
(make-writer-body
(lambda (port options)
(call-with-input-file filename
(lambda (in)
(copy-inport->outport in port)))))))))
(define (file-extension->content-type fname)
(let ((ext (file-name-extension fname)))
(cond
((string-ci=? ext ".htm") "text/html")
((string-ci=? ext ".html") "text/html")
((string-ci=? ext ".txt") "text/plain")
((string-ci=? ext ".doc") "application/msword")
((string-ci=? ext ".gif") "image/gif")
((string-ci=? ext ".png") "image/png")
((string-ci=? ext ".bmp") "image/bmp")
((or (string-ci=? ext ".jpg")
(string-ci=? ext ".jpeg")) "image/jpeg")
((or (string-ci=? ext ".tiff")
(string-ci=? ext ".tif")) "image/tif")
((string-ci=? ext ".rtf") "text/rtf")
((or (string-ci=? ext ".mpeg")
(string-ci=? ext ".mpg")) "video/mpeg")
((or (string-ci=? ext ".au")
(string-ci=? ext ".snd")) "audio/basic")
((string-ci=? ext ".wav") "audio/x-wav")
((string-ci=? ext ".dvi") "application/x-dvi")
((or (string-ci=? ext ".tex")
(string-ci=? ext ".latex")) "application/latex")
((string-ci=? ext ".zip") "application/zip")
((string-ci=? ext ".tar") "application/tar")
((string-ci=? ext ".hqx") "application/mac-binhex40")
((string-ci=? ext ".ps") "application/postscript")
((string-ci=? ext ".pdf") "application/pdf")
(else "application/octet-stream"))))
(define (file-extension->content-encoding fname)
(cond
((let ((ext (file-name-extension fname)))
(cond
((string-ci=? ext ".Z") "x-compress")
((string-ci=? ext ".gz") "x-gzip")
(else #f)))
=> (lambda (encoding)
(values (file-name-sans-extension fname) encoding)))
(else (values fname #f))))

97
scheme/httpd/handlers.scm
View File

@ -1,97 +0,0 @@
;;; http server in the Scheme Shell -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; Path handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Path handlers are the guys that actually perform the requested operation
;;; on the URL. The handler interface is
;;; (handler path-list request)
;;; The path-list is a URL path list that is a suffix of REQUEST's url's
;;; path-list. Path handlers can decide how to handle an operation by
;;; recursively keying off of the elements in path-list.
;;;
;;; The object-oriented view:
;;; One way to look at this is to think of the request's METHOD as a
;;; generic operation on the URL. Recursive request handlers do method
;;; lookup to determine how to implement a given operation on a particular
;;; path.
;;;
;;; The REQUEST is a request record, as defined in httpd-core.scm, containing
;;; the details of the client request.
;; general request handler combinator:
;; predicate: path x request --> boolean
;; if #t, handler is called
;; if #f, default-handler is called
(define (make-predicate-handler predicate handler default-handler)
(lambda (path req)
(if (predicate path req)
(handler path req)
(default-handler path req))))
;; same as MAKE-PREDICATE-HANDLER except that the predicate is only
;; called with the path:
;; predicate: path --> boolean
(define (make-path-predicate-handler predicate handler default-handler)
(make-predicate-handler
(lambda (path req) (predicate path)) handler default-handler))
;; selects handler according to host-field of http-request
(define (make-host-name-handler hostname handler default-handler)
(make-predicate-handler
(lambda (path req)
;; we expect only one host-header-field
(string=? hostname (string-trim (get-header (request-headers req) 'host))))
handler default-handler))
(define (get-header headers tag)
(cond
((assq tag headers) => cdr)
(else
(http-error (status-code bad-request) #f
(string-append "Request did not contain "
(symbol->string tag)
" header")))))
;; selects handler according to path-prefix
;; if path-prefix matches, handler is called without the path-prefix
(define (make-path-prefix-handler path-prefix handler default-handler)
(lambda (path req)
(if (and (pair? path) (string=? path-prefix (car path)))
(handler (cdr path) req)
(default-handler path req))))
;;; (alist-path-dispatcher handler-alist default-handler) -> handler
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This function creates a table-driven request handler that dispatches off
;;; of the car of the request path. The handler uses the car to index into
;;; a request handler alist. If it finds a hit, it recurses using the table's
;;; request handler. If no hits, it handles the path with a default handler.
;;; An alist handler is passed the tail of the original path; the
;;; default handler gets the entire original path.
;;;
;;; This procedure is how you say: "If the first element of the URL's
;;; path is 'foo', do X; if it's 'bar', do Y; otherwise, do Z."
(define (alist-path-dispatcher handler-alist default-handler)
(fold-right
(lambda (handler-pair default-handler)
(make-path-prefix-handler
(car handler-pair)
(cdr handler-pair)
default-handler))
default-handler
handler-alist))
;;; The null request handler -- handles nothing, sends back an error response.
;;; Can be useful as the default in table-driven request handlers.
(define (null-request-handler path req)
(make-error-response (status-code not-found) req))

59
scheme/httpd/http-top.scm
View File

@ -1,59 +0,0 @@
;;; Scheme Untergrund Web Server -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; This file contains a few example top-level request handlers and
;;; other useful fragments.
;;; - /h/<user>/<file-path> => serve <file-path> from ~user/public_html.
;;; - /seval You may POST Scheme code to this URL, and receive the output.
;;; - Otherwise, serve files from the standard HTTP demon repository.
(define rh1
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html"))
("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(rooted-file-handler "/usr/local/etc/httpd/htdocs")))
;;; Do a rough approximation of NCSA httpd server semantics:
;;; - /~shivers/... serves file ~shivers/public_html/...
;;; - /cgi-bin/<prog> passes control to script
;;; /usr/local/etc/httpd/cgi-bin/<prog>
;;; - Otherwise, just serve files out of the standard directory.
(define rh2
(alist-path-dispatcher
`(("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
;;; Greatest hits request handler.
(define rh3
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html"))
("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
;;; Crank up a server on port 8001, first resetting our identity to
;;; user "nobody". Initialise the request-invariant part of the CGI
;;; env before starting.
(define (httpd1)
(set-gid (->uid "nobody"))
(set-uid (->gid "nobody"))
(initialise-request-invariant-cgi-env)
(httpd (make-httpd-options with-request-handler rh3
with-port 8001
with-root-directory "/usr/local/etc/httpd/htdocs")))

655
scheme/httpd/info-gateway.scm
View File

@ -1,655 +0,0 @@
;;; GNU info -> HTML gateway for the SU web server. -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1996 by Mike Sperber.
;;; based on code with the same purpose by Gaebe Engelhart
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; (info-handler parse-info reference find-icon address) -> handler
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This function creates a request handler that converts GNU info pages
;;; on-the-fly. It is highly parameterizable to accomodate a wide
;;; range of environments. The parameters specify how to find the
;;; source code for the info pages, and how to generate certain
;;; elements of the generated HTML output.
;;;
;;; PARSE-INFO specifies how to parse the URLs that end up in the
;;; handler.
;;; It can be:
;;;
;;; * a procedure which is called with the URL as its parameters.
;;; It is expected to return with two values, FIND-ENTRY and
;;; NODE-NAME. FIND-ENTRY, in turn, can be either a procedure
;;; which gets passed the file name of an info node and is
;;; supposed to return with an absolute name of same. If it is a
;;; list, that list is taken as a list of directories in which to
;;; search for the info files. NODE-NAME is supposed to be the
;;; name of an info node of the form (<file>)<node>, extracted
;;; from the URL.
;;;
;;; * a list, in which case that is taken as a list of
;;; directories in which to search for the info files. The node
;;; name of a node is extracted from the URL by just taking the
;;; search component of the URL.
;;;
;;; * #f in which case the info path is taken from the environment
;;; variable INFOPATH, and the node name extraction works as
;;; above.
;;;
;;; REFERENCE specifies how to generate cross-references to other info
;;; nodes. It can be:
;;;
;;; * a procedure which gets called with the URL of the info page
;;; which contains the reference, and the node name of the node
;;; to be referenced. The procedure is expected to return the
;;; text for a link.
;;;
;;; * a string, in which case that is to be a prefix to which the
;;; node name is simply appended to yield the new link.
;;;
;;; * #f in which case all references have the form
;;; info?<node-name>.
;;;
;;; FIND-ICON specifies to to find the various icons used to decorate
;;; info pages. It can be:
;;;
;;; * a procedure which gets passed one of the tags in
;;; DEFAULT-ICON-ALIST and is supposed to return a link for the
;;; appropriate icon (or #f if no icon is to be used)
;;;
;;; * a string which is taken as a prefix to which one of the
;;; appropriate icon name from DEFAULT-ICON-ALIST is appended.
;;; (Note that these icon names were stolen from the
;;; cern-httpd-3.0 distribution at
;;; http://www.w3.org/pub/WWW/Daemon/.)
;;;
;;; * a list which is taken as an alist of the same format as
;;; DEFAULT-ICON-ALIST.
;;;
;;; * #f in which case no icons are used.
;;;
;;; ADDRESS a string to be appended at the bottom of all info pages
;;;
;;; To install a vanilla info handler for a prefix "info?" that looks
;;; in the environment variable INFOPATH, just use something like
;;; (info-handler #f #f #f "Generated by info-gateway")
;;; TODO: write a CGI version of this
(define-condition-type 'info-gateway-error '(error))
(define info-gateway-error? (condition-predicate 'info-gateway-error))
(define (info-gateway-error msg . irritants)
(apply signal 'info-gateway-error msg irritants))
(define default-icon-alist
'((info . "infodoc.gif")
(up . "up.gif")
(next . "next.gif")
(previous . "prev.gif")
(menu . "menu.gif")))
(define (info-handler parse-info reference find-icon address)
(let ((icon-name
(cond
((procedure? find-icon) find-icon)
((string? find-icon)
(let ((alist
(map (lambda (entry)
(cons (car entry)
(string-append find-icon (cdr entry))))
default-icon-alist)))
(lambda (tag)
(cond ((assq tag alist) => cdr)
(else #f)))))
((list? find-icon)
(lambda (tag)
(cond ((assq tag find-icon) => cdr)
(else #f))))
(else (lambda (tag) #f))))
(parse-info-url
(cond
((procedure? parse-info) parse-info)
((list? parse-info) ; it's an info path
(lambda (url)
(values parse-info
(unescape-uri (http-url-search url)))))
(else
(let ((info-path ((infix-splitter ":") (getenv "INFOPATH"))))
(lambda (url)
(values info-path
(unescape-uri (http-url-search url))))))))
(make-reference
(cond
((procedure? reference) reference)
((string? reference)
(lambda (url node-name)
(string-append reference node-name)))
(else
(lambda (url node-name)
(string-append "info?" node-name))))))
(lambda (path req)
(let ((request-method (request-method req)))
(cond
((string=? request-method "GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((info-gateway-error? c)
(apply http-error (status-code bad-gateway) req
(condition-stuff c)))
((http-error? c)
(apply http-error (car (condition-stuff c)) req
(cddr (condition-stuff c))))
(else
(decline))))
(make-response
(status-code ok)
#f
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(receive (find-entry node-name) (parse-info-url (request-url req))
(display-node node-name
(file-finder find-entry)
(referencer make-reference (request-url req) out)
icon-name
out))
(with-tag out address ()
(write-string address out)))))))
(else
(make-error-response (status-code method-not-allowed) req
request-method)))))))
(define split-header-line
(let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)")))
(split-field (infix-splitter (make-regexp ": *"))))
(lambda (l)
(let ((fields (map split-field (split l))))
(define (search-field regexp)
(cond
((find (lambda (field)
(string-match regexp (car field)))
fields)
=> cadr)
(else #f)))
(values (search-field "[F|f]ile")
(search-field "[N|n]ode")
(search-field "[U|u]p")
(search-field "[P|p]rev(ious)?")
(search-field "[N|n]ext"))))))
(define (replace-if-empty-string s v)
(if (zero? (string-length s))
v
s))
(define (string-newline->space s)
(string-map (lambda (c)
(if (char=? c #\newline)
#\space
c))
s))
(define (parse-node-name node-name)
(cond
((string-match "^\\((.*)\\)(.*)$" (string-newline->space node-name))
=> (lambda (match)
(values
(replace-if-empty-string (match:substring match 1) #f)
(replace-if-empty-string (match:substring match 2) "Top"))))
(else (values #f (string-newline->space node-name)))))
(define (unparse-node-name file node)
(let* ((ext (file-name-extension file))
(file (if (string=? ext ".info")
(file-name-sans-extension file)
file)))
(receive (file node) (if (and (string=? "dir" file)
(not (string=? "" node))
(not (string=? "Top" node)))
(values node "Top")
(values file node))
(string-append "(" file ")" node))))
(define (display-icon file alt out)
(emit-tag out 'img
(cons 'src file)
(cons 'alt alt)
(cons 'align "bottom")))
(define (referencer make-reference old-entry out)
(lambda (file node-name label . maybe-icon)
(receive (node-file node) (parse-node-name node-name)
(let ((file (or node-file file)))
(with-tag out a ((href (make-reference
old-entry
(escape-uri (unparse-node-name file node)))))
(if (and (not (null? maybe-icon))
(car maybe-icon))
(display-icon (car maybe-icon) (cadr maybe-icon) out))
(emit-text label out))))))
(define node-prologue (ascii->char 31))
(define node-epilogue-regexp
(make-regexp
(string-append (regexp-quote (string node-prologue))
"|"
(regexp-quote (string (ascii->char 12))))))
(define (string-starts-with-char? s c)
(and (not (zero? (string-length s)))
(char=? c (string-ref s 0))))
(define (node-prologue? s)
(string-starts-with-char? s node-prologue))
(define (node-epilogue? s)
(regexp-exec node-epilogue-regexp s))
;; Document title
(define (display-title file node up previous next
display-reference icon-name out)
(define (maybe-display-header header icon alt)
(if header
(begin
(newline out)
(with-tag out b ()
(display-reference file header header icon alt)))))
(emit-title out (string-append "Info Node: "
(unparse-node-name file node)))
(with-tag out h1 ()
(emit-tag out 'img
(cons 'src (icon-name 'info))
(cons 'alt "Info Node")
(cons 'align 'bottom))
(write-string (unparse-node-name file node) out))
(emit-tag out 'hr)
(maybe-display-header next (icon-name 'next) "[Next]")
(maybe-display-header previous (icon-name 'previous) "[Previous]")
(maybe-display-header up (icon-name 'up) "[Up]")
(if (or next previous up)
(emit-tag out 'hr)))
;; Text
;; Dealing with cross references
;; info sucks
(define xref-marker-regexp (make-regexp "\\*[Nn]ote([ \n]|$)"))
(define xref-regexp (make-regexp "\\*[Nn]ote *([^:]*): *([^\t\n,.;:?!]*)"))
(define max-xref-lines 3)
(define complete-line
(let ((split-xref-markers (field-splitter xref-marker-regexp))
(split-xrefs (field-splitter xref-regexp))
(cr (string #\newline)))
(lambda (line port)
(let loop ((line line) (count max-xref-lines))
(let ((xref-markers (split-xref-markers line))
(xrefs (split-xrefs line)))
(if (= (length xref-markers) (length xrefs))
line
(if (zero? count)
(info-gateway-error "invalid cross reference")
(let ((new-line (read-line port)))
(if (eof-object? new-line)
(info-gateway-error
"unexpected end of info file inside cross reference"))
(loop (string-append line cr new-line) (- count 1))))))))))
(define (display-xref xref file display-reference out)
(let* ((match (regexp-exec xref-regexp xref))
(note (match:substring match 1))
(node-name (match:substring match 2))
(node-name (if (string=? "" node-name) note node-name))
(node-name (substring node-name
(string-skip node-name char-set:whitespace)
(string-length node-name))))
(emit-text "See " out)
(display-reference file node-name note)))
(define display-text
(let ((split-xrefs (infix-splitter xref-regexp #f 'split)))
(lambda (line port file display-reference out)
(let* ((line (complete-line line port))
(components (split-xrefs line)))
;; in components, every 2nd element is a cross reference
;; also, it always has odd length or length zero
(if (not (null? components))
(let loop ((components components))
(emit-text (car components) out)
(if (not (null? (cdr components)))
(begin
(display-xref (cadr components) file display-reference out)
(loop (cddr components))))))
(newline out)))))
;; Menus
(define menu-regexp (make-regexp "^\\* +Menu:"))
(define menu-item-regexp (make-regexp "^\\* +"))
(define (char-splitter c)
(lambda (s)
(cond ((string-index s c)
=> (lambda (i)
(values (substring s 0 i)
(substring s (+ 1 i) (string-length s)))))
(else (values s "")))))
(define colon-split (char-splitter #\:))
(define (display-menu-item-header line port file display-reference icon-name out)
(let ((menu-line-split (infix-splitter menu-item-regexp)))
(receive (note rest) (colon-split (cadr (menu-line-split line)))
(receive (node-name text)
(cond
((string-match ": *(.*)" rest)
=> (lambda (match)
(values note (match:substring match 1))))
((string-match "^ *([^.]*)\\.? *(.*)" rest)
=> (lambda (match)
(values (match:substring match 1)
(match:substring match 2))))
(else
(info-gateway-error "invalid menu item")))
(emit-tag out 'dt)
(display-reference file node-name note (icon-name 'menu) "*")
(newline out)
(if (and (not (string=? "" text))
(not (string=? "." text)))
(begin
(emit-tag out 'dd)
(display-text text port file display-reference out)))))))
(define (display-menu line port file display-reference icon-name out)
(emit-close-tag out 'pre)
(with-tag out dl ()
(let loop ((line line))
(if (eof-object? line)
(info-gateway-error "unexpected end of info file"))
(display-menu-item-header line port file display-reference icon-name out)
(let finish-item-loop ()
(if (eof-object? line)
(info-gateway-error "unexpected end of info file"))
(let ((line (read-line port)))
(cond
((or (eof-object? line)
(node-epilogue? line)
(string=? "" line))
(emit-tag out 'pre)
(dispatch-line line port file display-reference icon-name out))
((regexp-exec menu-item-regexp line)
(loop line))
(else
(display-text line port file display-reference out)
(finish-item-loop))))))))
;; Central dispatch
(define (dispatch-line line port file display-reference icon-name out)
(cond
((or (eof-object? line) (node-epilogue? line)) #f)
((string=? "" line) (emit-p out) #t)
((regexp-exec menu-regexp line) #t) ;; this should probably be expanded
((regexp-exec menu-item-regexp line)
(display-menu line port file display-reference icon-name out))
(else
(display-text line port file display-reference out) #t)))
(define (display-body port file display-reference icon-name out)
(let loop ()
(let ((line (read-line port)))
(if (dispatch-line line port file display-reference icon-name out)
(loop)))))
(define (display-node node-name find-file display-reference icon-name out)
(receive (file node) (parse-node-name node-name)
(receive (port file-header node-header up-header prev-header next-header)
(find-node file node find-file)
(with-tag out html ()
(with-tag out head ()
(display-title file node-header up-header
prev-header next-header
display-reference icon-name
out))
(with-tag out body ()
(with-tag out pre ()
(display-body port file display-reference icon-name out))))
(close-input-port port))))
;; Finding nodes
(define (ensure-node-prologue port msg)
(let ((line (read-line port)))
(if (or (eof-object? line)
(not (node-prologue line)))
(info-gateway-error "invalid info file" msg))))
(define (ensure-regexp-line port regexp msg)
(let ((line (read-line port)))
(if (or (eof-object? line)
(not (string-match regexp line)))
(info-gateway-error "invalid info file" msg))))
(define (ensure-tag-table-node port)
(ensure-regexp-line port "^Tag Table:" "no tag table"))
(define (ensure-indirect-tag-table-header port)
(ensure-regexp-line port "^\\(Indirect\\)" "no indirect tag"))
(define split-indirection (infix-splitter (make-regexp " *: *")))
(define (parse-indirection line)
(let ((l (split-indirection line)))
(if (null? (cdr l))
(info-gateway-error "invalid indirection entry in info file")
(let ((file (car l))
(seek-pos (string->number (cadr l))))
(if (not seek-pos)
(info-gateway-error "invalid indirection entry in info file"))
(cons file seek-pos)))))
(define (read-indirection-table port)
(let loop ((table '()))
(let ((line (read-line port)))
(if (eof-object? line)
(info-gateway-error "invalid info file"))
(if (node-epilogue? line)
(reverse table)
(loop (cons (parse-indirection line) table))))))
(define tag-seek-separator (ascii->char 127))
(define parse-tag
(let ((split (infix-splitter (make-regexp ", *")))
(split-field (infix-splitter ": "))
(split-node-info
(infix-splitter (string tag-seek-separator))))
(define (barf)
(info-gateway-error "invalid tag entry in info file"))
(lambda (line)
(let* ((fields (map split-field (split line)))
(file (cond
((assoc "File" fields)
=> (lambda (p)
(if (null? (cdr p)) (barf))
(cadr p)))
(else #f))))
(cond
((assoc "Node" fields)
=> (lambda (p)
(if (null? (cdr p)) (barf))
(let ((s (split-node-info (cadr p))))
(if (null? (cdr p)) (barf))
(let* ((node (car s))
(seek (string->number (cadr s))))
(if (not seek) (barf))
(values node file seek)))))
(else (barf)))))))
(define (find-tag node port)
(let loop ()
(let ((line (read-line port)))
(if (eof-object? line)
(info-gateway-error "invalid info file"))
(if (regexp-exec node-epilogue-regexp line)
(http-error (status-code not-found) #f "node not found"))
(receive (entry-node file seek) (parse-tag line)
(if (string=? node entry-node)
(cons file seek)
(loop))))))
(define (find-indirection-entry seek-pos indirection-table)
(let loop ((table indirection-table))
(if (null? table)
(http-error (status-code not-found) #f "node not found"))
(let* ((entry (car table))
(pos (cdr entry)))
(if (and (>= seek-pos pos)
(or (null? (cdr table))
(let* ((next-entry (cadr table))
(next-pos (cdr next-entry)))
(< seek-pos next-pos))))
entry
(loop (cdr table))))))
(define (file-finder with)
(cond ((procedure? with) with)
((list? with)
(lambda (file)
(find-info-file file with)))))
(define (find-node-port-with-tag-entry node tag-entry ? find-file)
(let* ((port (if (input-port? ?) ? #f))
(indirection-table (if port #f ?))
(seek-pos (cdr tag-entry))
(indirection-entry
(and indirection-table
(find-indirection-entry seek-pos indirection-table)))
(seek-pos (if indirection-entry
(- seek-pos (cdr indirection-entry))
seek-pos))
;; that's what the documentation says ...
(seek-pos (if (>= seek-pos 1000)
(- seek-pos 1000)
0))
(file (or (car tag-entry)
(and indirection-entry
(car indirection-entry))))
(port (if file
(begin
(if port (close-input-port port))
(open-input-file (find-file file)))
port)))
(seek port seek-pos)
port))
(define (find-node file node find-file)
(if (not file)
(http-error (status-code not-found) #f
"no file in info node specification"))
(let* ((fname (find-file file))
(port (open-input-file fname)))
(let loop ((port port))
(let ((line (read-line port)))
(if (eof-object? line)
(http-error (status-code not-found) #f "info node not found"))
(if (node-prologue? line)
(let ((header (read-line port)))
(if (eof-object? header)
(info-gateway-error "invalid info file"))
(cond
((string-match "^Indirect:" header)
(let ((indirection-table
(read-indirection-table port)))
(ensure-tag-table-node port)
(ensure-indirect-tag-table-header port)
(let ((tag-entry (find-tag node port)))
(close-input-port port)
(loop (find-node-port-with-tag-entry
node tag-entry indirection-table find-file)))))
((string-match "^Tag Table:" header)
(let ((tag-entry (find-tag node port)))
(loop (find-node-port-with-tag-entry
node tag-entry port find-file))))
((string-match "^File:" header)
(receive
(file-header node-header up-header prev-header next-header)
(split-header-line header)
(if (string=? node-header node)
(values port
file-header node-header
up-header prev-header next-header)
(loop port))))
(else (loop port))))
(loop port))))))
;; Finding files
(define (info-file-alternative-names file)
(receive (dir base ext) (parse-file-name file)
(let* ((base
(cond ((string-match "(.*)-info$" base)
=> (lambda (match)
(match:substring match 1)))
(else base)))
(base-ci (string-map char-downcase base))
(alts-1 (if (string=? base base-ci)
(list base)
(list base base-ci)))
(alts (append alts-1
(map (lambda (base)
(string-append base ".info"))
alts-1)))
(alts (append alts
(map (lambda (base)
(string-append base "-info"))
alts-1)))
(alts (map (lambda (f) (string-append dir f)) alts))
(alts (cons file alts)))
alts)))
(define (find-info-file file info-path)
(let ((alts (info-file-alternative-names file)))
(let path-loop ((path info-path))
(if (null? path)
(http-error (status-code not-found) #f "info file not found"))
(let alt-loop ((alts alts))
(if (null? alts)
(path-loop (cdr path))
(let ((try (string-append (file-name-as-directory (car path))
(car alts))))
(if (file-exists? try)
try
(alt-loop (cdr alts)))))))))

196
scheme/httpd/logging.scm
View File

@ -1,196 +0,0 @@
;;; logging.scm
;;; logging functionality for web server
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Martin Gasbichler.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define do-nothing-proc (lambda a #f))
(define-record-type logging :logging
(really-make-logging log-port log-proc
syslog? syslog-proc
dns-lookup?)
logging?
;; port to perform CLF-logging
(log-port logging-log-port set-logging-log-port!)
;; proc to run for CLF-logging (req status-code)
(log-proc logging-log-proc set-logging-log-proc!)
;; do syslogging?
(syslog? logging-syslog? set-logging-syslog?!)
;; proc to run for syslog (level fmt . args)
(syslog-proc logging-syslog-proc set-logging-syslog-proc!)
;; perform dns lookups?
(dns-lookup? logging-dns-lookup? set-logging-dns-lookup?!))
(define (make-logging)
(really-make-logging #f
do-nothing-proc
#f
do-nothing-proc
#f))
(define logging (make-preserved-thread-fluid #f))
(define (make-fluid-selector selector)
(lambda () (selector (thread-fluid logging))))
(define (make-fluid-setter setter)
(lambda (value)
(setter (thread-fluid logging) value)))
(define logging-http-log-proc (make-fluid-selector logging-log-proc))
(define logging-http-syslog-proc (make-fluid-selector logging-syslog-proc))
(define logging-http-syslog? (make-fluid-selector logging-syslog?))
(define logging-http-log-port (make-fluid-selector logging-log-port))
(define logging-dns-lookup? (make-fluid-selector logging-dns-lookup?))
(define set-logging-http-log-proc (make-fluid-setter set-logging-log-proc!))
(define set-logging-http-syslog-proc (make-fluid-setter set-logging-syslog-proc!))
(define set-logging-http-syslog? (make-fluid-setter set-logging-syslog?!))
(define set-logging-http-log-port (make-fluid-setter set-logging-log-port!))
(define set-logging-dns-lookup? (make-fluid-setter set-logging-dns-lookup?!))
(define http-syslog
(lambda a
(apply (logging-http-syslog-proc) a)))
(define http-log
(lambda a
(apply (logging-http-log-proc) a)))
(define (http-syslog?)
(logging-http-syslog?))
(define (init-http-log! options)
;; syslog has to be initialized before CLF-logging
;; because the latter may generate syslog-messages
(init-http-syslog! (httpd-options-syslog? options))
(init-http-port-log! (httpd-options-logfile options))
(if (httpd-options-resolve-ips? options)
(set-logging-dns-lookup? #t)
(set-logging-dns-lookup? #f)))
(define (init-http-syslog! syslog?)
(if syslog?
(let ((http-syslog-lock (make-lock)))
(set-logging-http-syslog? #t)
(set-logging-http-syslog-proc
(lambda (level fmt . args)
(with-lock http-syslog-lock
(lambda ()
(syslog level
(apply format #f fmt args)))))))
(begin
(set-logging-http-syslog? #f)
(set-logging-http-syslog-proc do-nothing-proc))))
(define (init-http-port-log! logfile)
(let ((logport
(cond
((string? logfile) ; try to open logfile for appending (output)
(open-logfile logfile))
((output-port? logfile) ; we were given an output port, so let's use it
logfile)
((eq? logfile #f) ; no logging demanded
#f)
; unexpected value of logfile;
(else
(http-syslog
(syslog-level warning)
"[httpd] Warning: Logfile was not specified correctly (given: ~S).~% No CLF logging."
logfile)
(make-null-output-port)))))
(if logfile ; if logging was specified, set up the logger
(let ((http-log-lock (make-lock)))
(set-logging-http-log-port logport)
(if (string? logfile)
(spawn (make-logfile-rotator logfile http-log-lock)))
(set-logging-http-log-proc (make-http-log-proc http-log-lock))))))
(define (make-http-log-proc http-log-lock)
(lambda (req status-code)
(if req
(with-lock http-log-lock
(lambda ()
(display (make-CLF
(receive (host-address _)
(socket-address->internet-address
(socket-remote-address (request-socket req)))
(format-internet-host-address host-address))
(request-method req) ; request method
(uri-path->uri
(http-url-path (request-url req))) ; requested file
(version->string (request-version req)) ; protocol version
(status-code-number status-code)
23 ; filesize (unknown)
(get-header (request-headers req) 'referer)
(get-header (request-headers req) 'user-agent))
(logging-http-log-port))
(force-output (logging-http-log-port)))))))
(define (get-header headers tag)
(cond
((assq tag headers) => cdr)
(else "unknown")))
;; does the logfile rotation on signal USR1
(define (make-logfile-rotator logfile http-log-lock)
(set-interrupt-handler interrupt/usr1 #f)
(lambda ()
(on-interrupt
interrupt/usr1
(lambda ()
(with-lock http-log-lock
(lambda ()
(close-output-port (logging-http-log-port))
(set-logging-http-log-port (open-logfile logfile))))))))
(define (open-logfile logfile)
(with-errno-handler*
(lambda (errno packet)
(http-syslog (syslog-level warning)
"[httpd] Warning: An error occured while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
logfile
(car packet))
(make-null-output-port))
(lambda ()
(open-output-file logfile
(bitwise-ior open/create open/append)))))
; returns a string for a CLF entry (Common Log Format)
; note: till now, we do not log the user's time zone code
(define (make-CLF remote-ip request-type requested-file protocol http-code filesize referer user-agent)
(format #f "~A - - ~A ~S ~A ~A ~S ~S~%"
(or (maybe-dns-lookup remote-ip) "-")
(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date)) ; +0000 as we don't know
(string-join (list request-type
(string-append "/" requested-file)
protocol))
; Unfortunately, we first split the request line into
; method/request-type etc. and put it together here.
; Files conform to CLF are expected to print the original line.
(or http-code "-")
(or filesize "-")
(if (string? referer) (string-trim referer) "")
(if (string? user-agent)
(string-trim user-agent char-set:whitespace)
"")))
(define (maybe-dns-lookup remote-ip)
(if (logging-dns-lookup?)
(or (with-fatal-error-handler*
(lambda (condition decline)
(http-syslog (syslog-level debug)
"An error occured while resolving IP ~A: ~A"
remote-ip condition)
remote-ip)
(lambda ()
(dns-lookup-ip remote-ip)))
remote-ip)
remote-ip))

138
scheme/httpd/options.scm
View File

@ -1,138 +0,0 @@
;;; http server in the Scheme Shell -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; This package manages options to the http server as an abstract
;;; data type.
(define-record-type httpd-options :httpd-options
(really-make-httpd-options port
root-directory
icon-name
fqdn
reported-port
request-handler
server-admin
simultaneous-requests
logfile
syslog?
resolve-ips?)
httpd-options?
(port httpd-options-port
set-httpd-options-port!)
(root-directory httpd-options-root-directory
set-httpd-options-root-directory!)
;; ICON-NAME specifies how to generate the links to
;; various decorative icons for the listings. It can either be a
;; procedure which gets passed one of the icon tags in TAG->ICON and
;; is expected to return a link pointing to the icon. If it is a
;; string, that is taken as prefix to which the names from TAG->ICON
;; are appended.
(icon-name httpd-options-icon-name
set-httpd-options-icon-name!)
(fqdn httpd-options-fqdn
set-httpd-options-fqdn!)
(reported-port httpd-options-reported-port
set-httpd-options-reported-port!)
(request-handler httpd-options-request-handler
set-httpd-options-request-handler!)
(server-admin httpd-options-server-admin
set-httpd-options-server-admin!)
(simultaneous-requests httpd-options-simultaneous-requests
set-httpd-options-simultaneous-requests!)
(logfile httpd-options-logfile set-httpd-options-logfile!)
(syslog? httpd-options-syslog? set-httpd-options-syslog?!)
(resolve-ips? httpd-options-resolve-ips? set-httpd-options-resolve-ips?!))
; default httpd-options generation
(define (make-default-httpd-options)
(really-make-httpd-options 80 ; port
"/" ; root-directory
#f ; icon-name
#f ; fqdn
#f ; reported-port
#f ; request-handler
#f ; server-admin
#f ; simultaneous-requests
#f
; string: filename of logfile (directory must exist)
; output-port: log to this port (e.g. (current-error-port))
; #f: no logging
#t ; Do syslogging?
#t)) ; Write host names instead of IPs in logfiles?
; creates a copy of a given httpd-option
(define (copy-httpd-options options)
(let ((new-options (make-default-httpd-options)))
(set-httpd-options-port! new-options
(httpd-options-port options))
(set-httpd-options-root-directory! new-options
(httpd-options-root-directory options))
(set-httpd-options-icon-name! new-options
(httpd-options-icon-name options))
(set-httpd-options-fqdn! new-options
(httpd-options-fqdn options))
(set-httpd-options-reported-port! new-options
(httpd-options-reported-port options))
(set-httpd-options-request-handler! new-options
(httpd-options-request-handler options))
(set-httpd-options-server-admin! new-options
(httpd-options-server-admin options))
(set-httpd-options-simultaneous-requests!
new-options
(httpd-options-simultaneous-requests options))
(set-httpd-options-logfile! new-options (httpd-options-logfile options))
(set-httpd-options-syslog?! new-options (httpd-options-syslog? options))
(set-httpd-options-resolve-ips?! new-options (httpd-options-resolve-ips? options))
new-options))
; (make-httpd-options-transformer set-option!) -> lambda (new-value [httpd-option])
; creates a transformer for httpd-options
; the returned procedure is called with the new value for the option
; and optionally with the httpd-option to change
(define (make-httpd-options-transformer set-option!)
(lambda (new-value . stuff)
(let ((new-options (if (not (null? stuff))
(copy-httpd-options (car stuff))
(make-default-httpd-options))))
(set-option! new-options new-value)
new-options)))
; several transformers for port, root-directory, etc.
(define with-port
(make-httpd-options-transformer set-httpd-options-port!))
(define with-root-directory
(make-httpd-options-transformer set-httpd-options-root-directory!))
(define with-icon-name
(make-httpd-options-transformer set-httpd-options-icon-name!))
(define with-fqdn
(make-httpd-options-transformer set-httpd-options-fqdn!))
(define with-reported-port
(make-httpd-options-transformer set-httpd-options-reported-port!))
(define with-request-handler
(make-httpd-options-transformer set-httpd-options-request-handler!))
(define with-server-admin
(make-httpd-options-transformer set-httpd-options-server-admin!))
(define with-simultaneous-requests
(make-httpd-options-transformer set-httpd-options-simultaneous-requests!))
(define with-logfile
(make-httpd-options-transformer set-httpd-options-logfile!))
(define with-syslog?
(make-httpd-options-transformer set-httpd-options-syslog?!))
(define with-resolve-ips?
(make-httpd-options-transformer set-httpd-options-resolve-ips?!))
(define (make-httpd-options . stuff)
(let loop ((options (make-default-httpd-options))
(stuff stuff))
(if (null? stuff)
options
(let* ((transformer (car stuff))
(value (cadr stuff)))
(loop (transformer value options)
(cddr stuff))))))

47
scheme/httpd/request.scm
View File

@ -1,47 +0,0 @@
;;;; HTTP request
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1996 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;;; This code defines the http REQUEST data structure
(define-record-type request :request
(make-request method uri url version headers socket)
request?
(method request-method) ; A string such as "GET", "PUT", etc.
(uri request-uri) ; The escaped URI string as read from request line.
(url request-url) ; An http URL record (see url.scm).
(version request-version) ; A (major . minor) integer pair.
(headers request-headers) ; An rfc822 header alist (see rfc822.scm).
(socket request-socket)) ; The socket connected to the client.
(define-record-discloser :request
(lambda (req)
(list 'request
(request-method req)
(request-uri req)
(request-url req)
(request-version req)
(request-headers req)
(request-socket req))))
;;; A http protocol version is an integer pair: (major . minor).
(define (version< v1 v2)
(or (< (car v1) (car v2))
(and (= (car v1) (car v2))
(< (cdr v1) (cdr v2)))))
(define (version<= v1 v2) (not (version< v2 v1)))
(define (v0.9-request? req)
(version<= (request-version req) '(0 . 9)))
(define (version->string v)
(string-append "HTTP/"
(number->string (car v))
"."
(number->string (cdr v))))

256
scheme/httpd/response.scm
View File

@ -1,256 +0,0 @@
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define-record-type http-response :http-response
(make-response code message seconds mime extras body)
response?
(code response-code)
(message response-message)
(seconds response-seconds)
(mime response-mime)
(extras response-extras)
(body response-body))
;; This is mainly for nph-... CGI scripts.
;; This means that the body will output the entire MIME message, not
;; just the part after the headers.
(define-record-type http-nph-response :http-nph-response
(make-nph-response body)
nph-response?
(body nph-response-body))
(define-record-type http-writer-body :http-writer-body
(make-writer-body proc)
writer-body?
(proc writer-body-proc))
(define-record-type http-reader-writer-body :http-reader-writer-body
(make-reader-writer-body proc)
reader-writer-body?
(proc reader-writer-body-proc))
(define-record-type http-redirect-body :http-redirect-body
(make-redirect-body location)
redirect-body?
(location redirect-body-location))
(define (display-http-body body iport oport options)
(cond
((writer-body? body)
((writer-body-proc body) oport options))
((reader-writer-body? body)
((reader-writer-body-proc body) iport oport options))))
(define-finite-type status-code :http-status-code
(number message)
status-code?
status-codes
status-code-name
status-code-index
(number status-code-number)
(message status-code-message)
(
(ok 200 "OK")
(created 201 "Created")
(accepted 202 "Accepted")
(prov-info 203 "Provisional Information")
(no-content 204 "No Content")
(mult-choice 300 "Multiple Choices")
(moved-perm 301 "Moved Permanently")
(moved-temp 302 "Moved Temporarily")
(method 303 "Method (obsolete)")
(not-mod 304 "Not Modified")
(bad-request 400 "Bad Request")
(unauthorized 401 "Unauthorized")
(payment-req 402 "Payment Required")
(forbidden 403 "Forbidden")
(not-found 404 "Not Found")
(method-not-allowed 405 "Method Not Allowed")
(none-acceptable 406 "None Acceptable")
(proxy-auth-required 407 "Proxy Authentication Required")
(timeout 408 "Request Timeout")
(conflict 409 "Conflict")
(gone 410 "Gone")
(internal-error 500 "Internal Server Error")
(not-implemented 501 "Not Implemented")
(bad-gateway 502 "Bad Gateway")
(service-unavailable 503 "Service Unavailable")
(gateway-timeout 504 "Gateway Timeout")
(redirect -301 "Internal redirect")))
(define (name->status-code name)
(if (not (symbol? name))
(call-error name->status-code (list name))
(let loop ((i 0))
(cond ((= i (vector-length status-codes))
#f)
((eq? name
(status-code-name (vector-ref status-codes i)))
(vector-ref status-codes i))
(else
(loop (+ i 1)))))))
(define (number->status-code number)
(if (not (number? number))
(call-error number->status-code (list number))
(let loop ((i 0))
(cond ((= i (vector-length status-codes))
#f)
((= number
(status-code-number (vector-ref status-codes i)))
(vector-ref status-codes i))
(else
(loop (+ i 1)))))))
;;; (make-error-response status-code req [message . extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; As a special case, request REQ is allowed to be #f, meaning we haven't
;;; even had a chance to parse and construct the request. This is only used
;;; for 400 BAD-REQUEST error report.
(define (make-error-response code req . args)
(let* ((message (and (pair? args) (car args)))
(extras (if (pair? args) (cdr args) '()))
(generic-title (lambda (port)
(title-html port
(status-code-message code))))
(send-message (lambda (port)
(if message
(format port "<BR>~%Further Information: ~A<BR>~%" message))))
(close-html (lambda (port)
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
(write-string "</BODY>\n" port)))
(create-response
(lambda (headers writer-proc)
(make-response code
#f
(time)
"text/html"
headers
(make-writer-body writer-proc)))))
(cond
;; This error response requires two args: message is the new URI: field,
;; and the first EXTRA is the older Location: field.
((or (eq? code (status-code moved-temp))
(eq? code (status-code moved-perm)))
(create-response
(list (cons 'uri message)
(cons 'location (car extras)))
(lambda (port options)
(title-html port "Document moved")
(format port
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
(if (eq? code (status-code moved-temp))
"temporarily"
"permanently")
message)
(close-html port))))
((eq? code (status-code bad-request))
(create-response
'()
(lambda (port options)
(generic-title port)
(write-string "<P>Client sent a query that this server could not understand.\n"
port)
(send-message port)
(close-html port))))
((eq? code (status-code unauthorized))
(create-response
(list (cons 'WWW-Authenticate message)) ; Vas is das?
;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47
;; message should be a challenge(?)
(lambda (port options)
(title-html port "Authorization Required")
(write-string "<P>Browser not authentication-capable or\n" port)
(write-string "authentication failed.\n" port)
(send-message port)
(close-html port))))
((eq? code (status-code forbidden))
(create-response
'()
(lambda (port options)
(title-html port "Request not allowed.")
(format port
"Your client does not have permission to perform a ~A~%"
(request-method req))
(format port "operation on url ~a.~%" (request-uri req))
(send-message port)
(close-html port))))
((eq? code (status-code not-found))
(create-response
'()
(lambda (port options)
(title-html port "URL not found")
(write-string
"<P>The requested URL was not found on this server.\n"
port)
(send-message port)
(close-html port))))
((eq? code (status-code internal-error))
(create-response
'()
(lambda (port options)
(generic-title port)
(format port "The server encountered an internal error or
misconfiguration and was unable to complete your request.
<P>
Please inform the server administrator, ~A, of the circumstances leading to
the error, and time it occured.~%"
(or (httpd-options-server-admin options)
"[no mail address available]"))
(send-message port)
(close-html port))))
((eq? code (status-code not-implemented))
(create-response
'()
(lambda (port options)
(generic-title port)
(format port "This server does not currently implement
the requested method (~A).~%"
(request-method req))
(send-message port)
(close-html port))))
((eq? code (status-code bad-gateway))
(create-response
'()
(lambda (port options)
(generic-title port)
(format port "An error occured while waiting for the
response of a gateway.~%")
(send-message port)
(close-html port)))))))
(define (title-html out message)
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
(format out "<BODY>~%<H1>~A</H1>~%" message))
;; Creates a redirect response. The server will serve the new file indicated by
;; NEW-LOCATION. NEW-LOCATION must be uri-encoded and begin with a slash.
(define (make-redirect-response new-location)
(make-response
(status-code redirect)
#f
(time)
""
'()
(make-redirect-body new-location)))

190
scheme/httpd/rman-gateway.scm
View File

@ -1,190 +0,0 @@
;;; man page -> HTML gateway for the SU web server. -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1996-2003 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; This uses RosettaMan
;;; (based at ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
(define (rman-handler man-binary
nroff-binary
rman-binary
gzcat-binary
finder referencer address . maybe-man)
(let ((parse-man-url
(cond
((procedure? finder) finder)
((list? finder)
(lambda (url)
(values finder
(unescape-uri (http-url-search url))
'())))
(else
(let ((man-path ((infix-splitter ":") (getenv "MANPATH"))))
(lambda (url)
(values man-path
(unescape-uri (http-url-search url))
'()))))))
(reference-template
(cond
((procedure? referencer) referencer)
((string? referencer) (lambda (entry section) referencer))
(else (lambda (entry section) "man?%s(%s)"))))
(man (:optional maybe-man man)))
(lambda (path req)
(let ((request-method (request-method req)))
(cond
((string=? request-method "GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((http-error? c)
(apply http-error (car (condition-stuff c)) req
(cddr (condition-stuff c))))
(else
(decline))))
(make-response
(status-code ok)
#f
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(receive (man-path entry and-then)
(parse-man-url (request-url req))
(emit-man-page man-binary nroff-binary rman-binary
gzcat-binary
entry man man-path and-then reference-template out))
(with-tag out address ()
(display address out)))))))
(else
(make-error-response (status-code method-not-allowed) req
request-method)))))))
(define (cat-man-page key section out)
(let ((title (if section
(format #f "~a(~a) manual page" key section)
(format #f "~a manual page" key))))
(emit-title out title)
(emit-header out 1 title)
(newline out)
(with-tag out body ()
(with-tag out pre ()
(copy-inport->outport (current-input-port)
out)))))
(define (emit-man-page man-binary nroff-binary rman-binary
gzcat-binary
entry man man-path and-then reference-template out)
(receive (key section) (parse-man-entry entry)
(let ((status
(cond
((procedure? and-then)
(run (| (begin (man man-binary nroff-binary gzcat-binary
section key man-path))
(begin (and-then key section)))
(= 1 ,out)
(= 2 ,out)))
(else
(run (| (begin (man man-binary nroff-binary gzcat-binary
section key man-path))
(,rman-binary "-fHTML"
,@and-then
"-r" ,(reference-template entry section)))
(= 1 ,out)
(= 2 ,out))))))
(if (not (zero? status))
(error "internal error emitting man page")))))
(define parse-man-entry
(let ((entry-regexp (make-regexp "(.*)\\((.)\\)")))
(lambda (s)
(cond
((regexp-exec entry-regexp s)
=> (lambda (match)
(values (match:substring match 1)
(match:substring match 2))))
(else (values s #f))))))
(define (man man-binary nroff-binary gzcat-binary section key man-path)
(cond
((procedure? man-path) (man-path))
((find-man-file key section "cat" man-path) =>
(lambda (file)
(cat-n-decode gzcat-binary file)))
((find-man-file key section "man" man-path) =>
(lambda (file)
(nroff-n-decode nroff-binary file)))
(else
(if (not (zero?
(with-env (("MANPATH" . ,(string-join man-path ":")))
(run (,man-binary "-man" ,@(if section `(,section) '()) ,key)
stdports))))
(http-error (status-code not-found) #f "man page not found")))))
(define man-default-sections
'("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p"))
(define (find-man-file name section cat-man man-path . maybe-sections)
(define (section-dir section)
(lambda (dir)
(file-name-as-directory
(string-append (file-name-as-directory dir)
cat-man
section))))
(let* ((prefix (if section
(string-append name "." section)
(string-append name ".")))
(pattern (string-append (glob-quote prefix) "*"))
(sections (:optional maybe-sections man-default-sections))
(path (if section
(map (section-dir section) man-path)
(apply append
(map (lambda (dir)
(map (lambda (section)
((section-dir section) dir))
sections))
man-path)))))
(let loop ((path path))
(and (not (null? path))
(let ((matches (glob (string-append (car path) pattern))))
(if (not (null? matches))
(car matches)
(loop (cdr path))))))))
(define (file->man-directory file)
(path-list->file-name
(reverse
(cdr
(reverse
(split-file-name
(file-name-directory file)))))))
(define (cat-n-decode gzcat-binary file)
(let ((ext (file-name-extension file)))
(cond
((string=? ".gz" ext) (run (,gzcat-binary ,file) stdports))
((string=? ".Z" ext) (run (,gzcat-binary ,file) stdports))
(else (call-with-input-file
file
(lambda (port)
(copy-inport->outport port (current-output-port))))))))
(define (nroff-n-decode nroff-binary gzcat-binary file)
(if (not (zero? (run (| (begin (cat-n-decode gzcat-binary file))
(begin
(with-cwd (file->man-directory file)
(exec-epf (,nroff-binary "-man")))))
stdports)))
(http-error (status-code not-found) #f "man page not found")))

50
scheme/httpd/server.scm
View File

@ -1,50 +0,0 @@
#!/bin/sh
IFS=" "
exec scsh -lm ../packages.scm -dm -o http-top -e top -s "$0" "$@"
!#
;;; Scheme Underground Web Server -*- Scheme -*-
;;; Olin Shivers
;;; To compile as a heap-image:
;;; ,open http-top
;;; (dump-scsh-program top "server")
;;; then insert a #! trigger.
(define-structure http-top (export top)
(open httpd-core
httpd-make-options
httpd-cgi-server
httpd-basic-handlers
httpd-seval-handlers
scheme-with-scsh)
(begin
;; Kitchen-sink request handler.
(define rh
(alist-path-dispatcher
`(("h" . ,(home-dir-handler "public_html"))
("seval" . ,seval-handler)
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
(tilde-home-dir-handler "public_html"
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
;; Crank up a server on port 8001, first resetting our identity to
;; user "nobody". Initialise the request-invariant part of the CGI
;; env before starting.
(define (top args)
(display "We be jammin, now.\n") (force-output)
(cond ((zero? (user-uid))
(set-gid (->gid "nobody"))
(set-uid (->uid "nobody"))))
;; invariant environment is know initilialized by cgi-handler itself
;; (initialise-request-invariant-cgi-env)
(httpd (with-request-handler
rh
(with-port
8001
(with-root-directory "/usr/local/etc/httpd")))))))

104
scheme/httpd/seval.scm
View File

@ -1,104 +0,0 @@
;;; Path handler for uploading Scheme code to the SU web server -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; This is really just an handler example demonstrating how to upload code
;;; into the server.
;;; (do/timeout secs thunk)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds.
;;; Returns nothing useful, and THUNK gets executed in a subprocess,
;;; so its side-effects are invisible, as well. This is a clever kludge --
;;; it uses three subprocesses -- but I don't have interrupts, so I'm hosed.
(define (do/timeout* secs thunk)
(run (begin (let ((timer (fork (lambda () (sleep secs))))
(worker (fork thunk)))
(receive (process status) (wait-any)
(ignore-errors
(lambda ()
(signal-process (proc:pid (if (eq? worker process)
timer
worker))
signal/kill))))))))
(define-syntax do/timeout
(syntax-rules ()
((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))
;;; The request handler for seval ops.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (seval-handler path req)
(let ((request-method (request-method req)))
(cond
((string=? request-method "POST") ; Could do others also.
(seval path req))
(else
(make-error-response (status-code method-not-allowed) req request-method)))))
(define (seval path req)
(make-response
(status-code ok)
#f
(time)
"text/html"
'()
(make-reader-writer-body
(lambda (iport oport options)
(let ((sexp (read-request-sexp req iport)))
(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
(with-tag oport HEAD ()
(newline oport)
(emit-title oport "Scheme program output"))
(newline oport)
(with-tag oport BODY ()
(newline oport)
(do/timeout
10
(receive vals
;; Do the computation.
(begin (emit-header oport 2 "Output from execution")
(newline oport)
(with-tag oport PRE ()
(newline oport)
(force-output oport); In case we're gunned down.
(eval-safely sexp)))
;; Pretty-print the returned value(s).
(emit-header oport 2 "Return value(s)")
(with-tag oport PRE ()
(for-each (lambda (val) (p val oport))
vals))))))))))
;;; Read an HTTP request entity body from stdin. The Content-length:
;;; element of request REQ's header tells how many bytes to this entity
;;; is. The entity should be a URI-encoded form body. Pull out the
;;; program=<stuff>
;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
;;; and return it.
(define (read-request-sexp req iport)
(cond
((get-header (request-headers req) 'content-length) =>
(lambda (cl-str) ; Take the first Content-length: header,
(let* ((cl-start (string-skip cl-str char-set:whitespace)) ; skip whitespace,
(cl (if cl-start ; & convert to
(string->number (substring cl-str ; a number.
cl-start
(string-length cl-str)))
0)) ; All whitespace?? -- WTF.
(qs (read-string cl iport)) ; Read in CL chars,
(q (parse-html-form-query qs)) ; and parse them up.
(s (cond ((assoc "program" q) => cdr)
(else (error "No program in entity body.")))))
(http-syslog (syslog-level debug)
"Seval sexp: ~s" s)
(read (make-string-input-port s)))))
(else (error "No `Content-length:' field in POST request."))))

51
scheme/lib/cgi-script.scm
View File

@ -1,51 +0,0 @@
;;; NCSA's WWW Common Gateway Interface -- script-side code -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
;;; This file provides routines to help you write programs in Scheme
;;; that can interface to HTTP servers using the CGI program interface
;;; to carry out HTTP transactions.
;;; ISINDEX queries:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (Likewise for ISINDEX URL queries from browsers.)
;;; Browser url-form encodes the query (see above), which then becomes the
;;; ?<search> part of the URI. (Hence the CGI script will split the individual
;;; fields into argv[].)
;;; CGI interface:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
;;; - If it contains no raw "=" chars, it is split at "+" chars. The
;;; substrings are URI decoded, and become the elts of argv[]. You aren't
;;; supposed to rely on this unless you are replying to ISINDEX queries.
;;; - The CGI script is run with stdin hooked up to the socket. If it's going
;;; to read the entity, it should read $CONTENT_LENGTH bytes worth.
;;; - A bunch of env vars are set with useful values.
;;; - Entity block is passed to script on stdin;
;;; script writes reply to stdout.
;;; - If the script begins with "nph-" its output is the entire reply.
;;; Otherwise, when it replies to the server, it sends back a special
;;; little header that tells the server how to construct the real header
;;; for the reply.
;;; See the "spec" for further details. (URL above)
(define (cgi-form-query)
(let ((request-method (getenv "REQUEST_METHOD")))
(cond
((string=? request-method "GET")
(parse-html-form-query (getenv "QUERY_STRING")))
((string=? request-method "POST")
(let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
(parse-html-form-query (read-string nchars))))
(else (error "Method not handled."))))) ; Don't be calling me.

50
scheme/lib/crlf-io.scm
View File

@ -1,50 +0,0 @@
;;; Read cr/lf and lf terminated lines. -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; (read-crlf-line [fd/port retain-crlf?]) -> string or EOF object
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read a line terminated by either line-feed or EOF. If RETAIN-CRLF? is #f
;;; (the default), a terminating cr/lf or lf sequence is trimmed from the
;;; returned string.
;;;
;;; This is simple and inefficient. It would be save one copy if we didn't
;;; use READ-LINE, but replicated its implementation instead.
(define (read-crlf-line . args)
(let-optionals args ((fd/port (current-input-port))
(retain-crlf? #f))
(let ((ln (read-line fd/port retain-crlf?)))
(if (or retain-crlf? (eof-object? ln))
ln
(let ((slen (string-length ln))) ; Trim a trailing cr, if any.
(if (or (zero? slen)
(not (char=? (string-ref ln (- slen 1)) cr)))
ln
(substring ln 0 (- slen 1))))))))
(define cr (ascii->char 13))
(define (write-crlf port)
(write-string "\r\n" port)
(force-output port))
(define (read-crlf-line-timeout . args)
(let-optionals args ((fd/port (current-input-port))
(retain-crlf? #f)
(timeout 8000)
(max-interval 500))
(let loop ((waited 0) (interval 100))
(cond ((> waited timeout)
'timeout)
((char-ready? fd/port)
(read-crlf-line fd/port retain-crlf?))
(else (sleep interval)
(loop (+ waited interval) (min (* interval 2)
max-interval)))))))

1567
scheme/lib/dns.scm
View File

File diff suppressed because it is too large Load Diff

39
scheme/lib/format-net.scm
View File

@ -1,39 +0,0 @@
;; Pretty-printing of IPv4 Internet addresses
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;; ADDRESS address to pretty-print
;; SEPERATOR optional, defaults to ".", seperator between address-parts
;; Example:
;; (format-internet-host-address #x0a00ffff)
;; ==> "10.0.255.255"
;; (format-internet-host-address #x0a00ffff ":")
;; ==> "10:0:255:255"
(define (format-internet-host-address address . maybe-separator)
(let ((extract (lambda (shift)
(number->string
(bitwise-and (arithmetic-shift address (- shift))
255)))))
(let-optionals maybe-separator ((separator "."))
(string-append
(extract 24) separator (extract 16) separator
(extract 8) separator (extract 0)))))
;; does pretty-print of ports
;; Example:
;; (format-port #x0aff)
;; => "10,255"
(define (format-port port)
(string-append
(number->string (bitwise-and (arithmetic-shift port -8) 255))
","
(number->string (bitwise-and port 255))))

76
scheme/lib/ftp-library.scm
View File

@ -1,76 +0,0 @@
; Utility library for FTP clients and servers
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998-2002 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define *window-size* 4096)
(define (copy-port->port-binary input-port output-port)
(let ((buffer (make-string *window-size*)))
(let loop ()
(cond
((read-string! buffer input-port)
=> (lambda (length)
(write-string buffer output-port 0 length)
(loop))))))
(force-output output-port))
(define (copy-port->port-ascii input-port output-port)
(let loop ()
(let ((line (read-line input-port 'concat)))
(if (not (eof-object? line))
(let ((length (string-length line)))
(cond
((zero? length)
'fick-dich-ins-knie)
((char=? #\newline (string-ref line (- length 1)))
(write-string line output-port 0 (- length 1))
(write-crlf output-port))
(else
(write-string line output-port)))
(loop)))))
(force-output output-port))
(define (copy-ascii-port->port input-port output-port)
(let loop ()
(let* ((line (read-crlf-line input-port
#f))
(length (string-length line)))
(if (not (eof-object? line))
(begin
(write-string line output-port 0 length)
(newline output-port)
(loop)))))
(force-output output-port))
(define *port-arg-regexp*
(make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))
(define (parse-port-arg string)
(cond
((regexp-exec *port-arg-regexp* string)
=> (lambda (match)
(let ((components
(map (lambda (match-index)
(string->number
(match:substring match match-index)))
'(1 2 3 4 5 6))))
(if (any (lambda (component)
(> component 255))
components)
(call-error "invalid PORT argument" parse-port-arg))
(apply
(lambda (a1 a2 a3 a4 p1 p2)
(let ((address (+ (arithmetic-shift a1 24)
(arithmetic-shift a2 16)
(arithmetic-shift a3 8)
a4))
(port (+ (arithmetic-shift p1 8) p2)))
(values address port)))
components))))
(else
(call-error "invalid PORT argument" parse-port-arg))))

436
scheme/lib/ftp.scm
View File

@ -1,436 +0,0 @@
;;; ftp.scm -- an FTP client library for the Scheme Shell
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998 by Eric Marsden.
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;; The following rfc959 commands are not implemented:
;;
;; * ACCT (account; this is ignored by most servers)
;; * SMNT (structure mount, for mounting another filesystem)
;; * REIN (reinitialize connection)
;; * LOGOUT (quit without interrupting ongoing transfers)
;; * STRU (file structure)
;; * ALLO (allocate space on server)
;;; Related work ======================================================
;;
;; * rfc959 describes the FTP protocol; see
;; http://www.ietf.org/rfc/rfc959.txt
;;
;; * /anonymous@sunsite.unc.edu:/pub/Linux/libs/ftplib.tar.gz is a
;; library similar to this one, written in C, by Thomas Pfau
;;
;; * FTP.pm is a Perl module with similar functionality (available
;; from http://www.perl.com/CPAN)
;;
;; * XEmacs gets transparent remote file access from EFS.
;; However, it cheats by using /usr/bin/ftp.
;;
;; * Siod (a small-footprint Scheme implementation by George Carette)
;; comes with a file ftp.scm with a small subset of these functions
;; defined
;;; TODO ============================================================
;;
;; * Unix-specific commands such as SITE UMASK, SITE CHMOD
;; * improved error handling
;; Communication is initiated by the client. The server responds to
;; each request with a three digit status code and an explanatory
;; message, and occasionally with data (which is sent via a separate,
;; one-off channel). The client starts by opening a command connection
;; to a well known port on the server machine. Messages send to the
;; server are of the form
;;
;; CMD [ <space> arg ] <CR> <LF>
;;
;; Replies from the server are of the form
;;
;; xyz <space> Informative message <CR> <LF>
;;
;; where xyz is a three digit code which indicates whether the
;; operation succeeded or not, whether the server is waiting for more
;; data, etc. The server may also send multiline messages of the form
;;
;; xyz- <space> Start of multiline message <CR> <LF>
;; [ <space>+ More information ]* <CR> <LF>
;; xyz <space> End of multiline message <CR> <LF>
;;
;; Some of the procedures in this module extract useful information
;; from the server's reply, such as the size of a file, or the name of
;; the directory we have moved to. These procedures return either the
;; extracted information, or #f to indicate failure. Other procedures
;; return a "status", which is either the server's reply as a string,
;; or #f to signify failure.
;; beware, the log file contains password information!
(define (ftp-connect host login password passive? . args)
(let-optionals* args ((log #f))
(let* ((hst-info (host-info host))
(hostname (host-info:name hst-info))
(srvc-info (service-info "ftp" "tcp"))
(sock (socket-connect protocol-family/internet
socket-type/stream
hostname
(service-info:port srvc-info)))
(connection (make-ftp-connection hostname
sock
passive?
log)))
(ftp-log connection
(string-append "-- "
(date->string (date))
": opened ftp connection to "
hostname))
(ftp-read-reply connection (exactly-code "220")) ; the initial welcome banner
(ftp-login connection login password)
connection)))
;; Send user information to the remote host. Args are login
;; and password. If they are not provided, the Netrc module is used to
;; try to determine a login and password for the server.
(define (ftp-login connection login password)
(let* ((netrc-record #f)
(get-netrc-record
(lambda ()
(cond
(netrc-record)
(else
(set! netrc-record
(netrc-machine-entry (ftp-connection-host-name connection) #t))
netrc-record)))))
(let ((login (or login
(netrc-entry-login (get-netrc-record)))))
(let ((reply
(ftp-send-command connection (build-command "USER" login)
(lambda (code)
(or (string=? code "331") ; "User name okay, need password."
(string=? code "230")))))) ; "User logged in, proceed."
(if (string-prefix? "331" reply) ; "User name okay, need password."
(ftp-send-command connection
(build-command
"PASS"
(or password
(netrc-entry-password (get-netrc-record))))
(exactly-code "230")))))))
(define-enumerated-type ftp-type :ftp-type
ftp-type?
ftp-types
ftp-type-name
ftp-type-index
(binary ascii))
(define (ftp-set-type! connection type)
(let ((ttype (cond
((eq? type (ftp-type binary)) "I")
((eq? type (ftp-type ascii)) "A"))))
(ftp-send-command connection (build-command "TYPE" ttype))
(values)))
(define (ftp-rename connection oldname newname)
(ftp-send-command connection (build-command "RNFR " oldname)
(code-with-prefix "35"))
(ftp-send-command connection (build-command "RNTO" newname)
(code-with-prefix "25"))
(values))
(define (ftp-delete connection file)
(ftp-send-command connection (build-command "DELE" file)
(code-with-prefix "25"))
(values))
;;: connection x string -> status
(define (ftp-cd connection dir)
(ftp-send-command connection (build-command "CWD" dir))
(values))
;;: connection -> status
(define (ftp-cdup connection)
(ftp-send-command connection "CDUP" (exactly-code "250"))
(values))
;;: on success return the new directory as a string
(define (ftp-pwd connection)
(let ((reply (ftp-send-command connection "PWD" (exactly-code "257"))))
(cond
((regexp-search (rx (seq bos (= 3 digit) #\space
(* (~ #\")) #\" (submatch (* (~ #\"))) #\"))
reply)
=> (lambda (match)
(match:substring match 1))))))
(define (ftp-rmdir connection dir)
(ftp-send-command connection (build-command "RMD " dir))
(values))
(define (ftp-mkdir connection dir)
(ftp-send-command connection (build-command "MKD ~a" dir))
(values))
;; On success return a Scsh date record. This message is not part of
;; rfc959 but seems to be supported by many ftp servers (it's useful
;; for mirroring)
(define (ftp-modification-time connection file)
(let* ((reply (ftp-send-command connection
(build-command "MDTM" file)))
(timestr (substring reply 4 (string-length reply))))
(let ((year (substring timestr 0 4))
(month (substring timestr 4 6))
(mday (substring timestr 6 8))
(hour (substring timestr 8 10))
(min (substring timestr 10 12))
(sec (substring timestr 12 14)))
(make-date (string->number sec)
(string->number min)
(string->number hour)
(string->number mday)
(string->number month)
(- (string->number year) 1900)))))
;; On success return the size of the file in bytes.
;;: connection x string -> integer
(define (ftp-size connection file)
(let* ((reply (ftp-send-command connection
(build-command "SIZE" file))))
(string->number (substring reply
4 (string-length reply)))))
;; Abort the current data transfer. Maybe we should close the data
;; socket?
(define (ftp-abort connection)
(ftp-send-command connection "ABOR")
(values))
(define (ftp-quit connection)
(ftp-send-command connection "QUIT" (exactly-code "221"))
(close-socket (ftp-connection-command-socket connection)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following commands require the use of a data connection as well
;; as the command connection. The command and the server's reply are
;; transmitted via the command connection, while the data is
;; transmitted via the data connection (you could have guessed that,
;; right?).
;;
;; The data socket is created by the client, who sends a PORT command
;; to the server to indicate on which port it is ready to accept a
;; connection. The port command specifies an IP number and a port
;; number, in the form of 4+2 comma-separated bytes. The server then
;; initiates the data transfer. A fresh data connection is created for
;; each data transfer (unlike the command connection which stays open
;; during the entire conversation with the server).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ftp-ls connection . maybe-dir)
(with-data-connection
connection
(lambda ()
(ftp-send-command connection
(apply build-command "NLST" maybe-dir)
(code-with-prefix "1")))
(lambda (data-socket)
(port->lines (socket:inport data-socket)))))
(define (find-port-arg string)
(cond
((regexp-search (rx (: (+ digit) (= 5 (: #\, (+ digit))))) string)
=> (lambda (match)
(match:substring match 0)))))
(define (ftp-dir connection . maybe-dir)
(with-data-connection
connection
(lambda ()
(ftp-send-command connection
(apply build-command "LIST" maybe-dir)
(code-with-prefix "1")))
(lambda (data-socket)
(port->lines (socket:inport data-socket)))))
(define (port->lines port)
(let loop ((reverse-lines '()))
(let ((line (read-crlf-line port)))
(if (eof-object? line)
(reverse reverse-lines)
(loop (cons line reverse-lines))))))
(define (ftp-get connection remote-file act)
(with-data-connection
connection
(lambda ()
(ftp-send-command connection
(build-command "RETR" remote-file)
(exactly-code "150")))
(lambda (data-socket)
(act (socket:inport data-socket)))))
;; FIXME: should have an optional argument :rename which defaults to
;; false, which would make us upload to a temporary name and rename at
;; the end of the upload. This atomicity is important for ftp or http
;; servers which are serving a load, and to avoid problems with "no
;; space on device".
(define (ftp-put connection remote-file act)
(with-data-connection
connection
(lambda ()
(ftp-send-command connection (build-command "STOR" remote-file)
(exactly-code "150")))
(lambda (data-socket)
(act (socket:outport data-socket)))))
(define (ftp-append connection remote-file act)
(with-data-connection
connection
(lambda ()
(ftp-send-command connection (build-command "APPE" remote-file)
(exactly-code "150"))
(lambda (data-socket)
(act (socket:outport data-socket))))))
;; send a command verbatim to the remote server and wait for a
;; reply.
(define (ftp-quot connection cmd)
(ftp-send-command connection cmd))
;; ------------------------------------------------------------------------
;; no exported procedures below
(define (with-data-connection connection command-thunk proc)
(if (ftp-connection-passive-mode? connection)
(let* ((pasv-reply (ftp-send-command connection "PASV" (exactly-code "227")))
(port-arg (find-port-arg pasv-reply)))
(call-with-values
(lambda () (parse-port-arg port-arg))
(lambda (address port)
(let ((data-socket (create-socket protocol-family/internet
socket-type/stream)))
(set-socket-option data-socket level/socket socket/reuse-address #t)
(connect-socket data-socket
(internet-address->socket-address
address port))
(command-thunk)
(let ((retval (proc data-socket)))
(close-socket data-socket)
(ftp-read-reply connection)
retval)))))
(let* ((sock (create-socket protocol-family/internet
socket-type/stream))
(sockaddr (internet-address->socket-address
internet-address/any
0))) ; 0 to accept any port
(set-socket-option sock level/socket socket/reuse-address #t)
(set-socket-option sock level/socket socket/linger 120)
(bind-socket sock sockaddr)
(listen-socket sock 0)
(ftp-send-command connection ; send PORT command
(ftp-build-PORT-string (socket-local-address sock)))
(command-thunk)
(receive (data-socket data-socket-address)
(accept-connection sock)
(let ((retval (proc data-socket)))
(close-socket data-socket)
(close-socket sock)
(ftp-read-reply connection)
retval)))))
;; TODO: Unix-specific commands
;; SITE UMASK 002
;; SITE IDLE 60
;; SITE CHMOD 755 filename
;; SITE HELP
;; We cache the login and password to be able to relogin automatically
;; if we lose the connection (a la ange-ftp). Not implemented.
(define-record-type ftp-connection :ftp-connection
(make-ftp-connection host-name command-socket passive-mode? logfd)
ftp-connection?
(host-name ftp-connection-host-name)
(command-socket ftp-connection-command-socket)
(passive-mode? ftp-connection-passive-mode?)
(logfd ftp-connection-logfd))
(define-condition-type 'ftp-error '(error))
(define ftp-error? (condition-predicate 'ftp-error))
(define (ftp-build-PORT-string sockaddr)
(let* ((hst-info (host-info (system-name)))
(ip-address (car (host-info:addresses hst-info))))
(receive (hst-address srvc-port)
(socket-address->internet-address sockaddr)
(string-append "PORT "
(format-internet-host-address ip-address ",")
","
(format-port srvc-port)))))
(define (ftp-send-command connection command . maybe-expected)
(let* ((sock (ftp-connection-command-socket connection))
(out (socket:outport sock)))
(write-string command out)
(write-crlf out)
(ftp-log connection (string-append "<- " command))
(apply ftp-read-reply connection maybe-expected)))
(define any-code (lambda (code) #t))
(define (code-with-prefix prefix)
(lambda (code)
(string-prefix? prefix code)))
(define (exactly-code the-code)
(lambda (code)
(string=? code the-code)))
;; This is where we check that the server's 3 digit status code
;; corresponds to what we expected.
;; EXPECTED? is a predicate on reply codes. If the server's reply
;; doesn't satisfy EXPECTED?, we raise an FTP-ERROR.
(define (ftp-read-reply connection . maybe-expected)
(let-optionals* maybe-expected ((expected? (code-with-prefix "2")))
(let* ((sock (ftp-connection-command-socket connection))
(in (socket:inport sock))
(reply (read-crlf-line in))
(code (substring reply 0 3)))
(ftp-log connection (string-append "-> " reply))
(if (not (expected? code))
(signal 'ftp-error reply))
;; handle multi-line replies
(if (char=? (string-ref reply 3) #\-)
(let ((end-prefix (string-append code " ")))
(let loop ()
(let* ((line (read-crlf-line in))
(reply (string-join (list reply line "\n"))))
(ftp-log connection (string-append "-> " line))
(if (string-prefix? end-prefix line)
reply
(loop)))))
reply))))
(define (build-command str . opt-args)
(string-join (cons str opt-args)))
(define (ftp-log connection line)
(cond
((ftp-connection-logfd connection)
=> (lambda (log)
(write-string line log)
(write-string "\n" log)
(force-output log)))))

97
scheme/lib/handle-fatal-error.scm
View File

@ -1,97 +0,0 @@
;;; Handle fatal errors in a sensible way. -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; (with-fatal-error-handler* handler thunk)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Call THUNK, and return whatever it returns. If THUNK signals a condition,
;;; and that condition is an error condition (or a subtype of error), then
;;; HANDLER gets a chance to handle it.
;;; The HANDLER proc is applied to two values:
;;; (HANDLER condition decline)
;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER
;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to
;;; handle the error by throwing to DECLINE, a nullary continuation.
;;;
;;; Why is it called with-FATAL-error-handler*? Because returning to the
;;; guy that signalled the error is not an option.
;;;
;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's
;;; error handler *itself* raises an error? This could potentially give
;;; rise to an infinite loop, because WITH-HANDLER runs its handler in
;;; the original condition-signaller's context, so you'd search back for a
;;; handler, and find yourself again. For example, here is an infinite loop:
;;;
;;; (with-handler (lambda (condition more)
;;; (display "Loop!")
;;; (error "ouch")) ; Get back, Loretta.
;;; (lambda () (error "start me up")))
;;;
;;; I could require W-F-E-H* users to code carefully, but instead I make sure
;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so
;;; if it signals a condition, we'll start the search from there. That's the
;;; point of continuation K. When the original thunk completes successfully,
;;; we dodge the K hackery by using ACCEPT to make a normal return.
(define (with-fatal-error-handler* handler thunk)
(call-with-current-continuation
(lambda (accept)
((call-with-current-continuation
(lambda (k)
(with-handler (lambda (condition more)
(if (error? condition)
(call-with-current-continuation
(lambda (decline)
(k (lambda () (handler condition decline))))))
(more)) ; Keep looking for a handler.
(lambda () (call-with-values thunk accept)))))))))
(define-syntax with-fatal-error-handler
(syntax-rules ()
((with-fatal-error-handler handler body ...)
(with-fatal-error-handler* handler
(lambda () body ...)))))
;This one ran HANDLER in the signaller's condition-handler context.
;It was therefore susceptible to infinite loops if you didn't code
;your handler's carefully.
;
;(define (with-fatal-error-handler* handler thunk)
; (call-with-current-continuation
; (lambda (accept)
; (with-handler (lambda (condition more)
; (if (error? condition)
; (call-with-current-continuation
; (lambda (decline)
; (accept (handler condition decline)))))
; (more)) ; Keep looking for a handler.
; thunk))))
;;; (%error-handler-cond kont eh-clauses cond-clauses)
;;; Transform error-handler clauses into COND clauses by wrapping continuation
;;; KONT around the body of each e-h clause, so that if it fires, the result
;;; is thrown to KONT, but if no clause fires, the cond returns to the default
;;; continuation.
;(define-syntax %error-handler-cond
; (syntax-rules (=> else)
;
; ((%error-handler-cond kont ((test => proc) clause ...) (ans ...))
; (%error-handler-cond kont
; (clause ...)
; ((test => (lambda (v) (kont (proc v)))) ans ...)))
;
; ((%error-handler-cond kont ((test body ...) clause ...) (ans ...))
; (%error-handler-cond kont
; (clause ...)
; ((test (kont (begin body ...))) ans ...)))
;
; ((%error-handler-cond kont ((else body ...)) (ans-clause ...))
; (cond (else body ...) ans-clause ...))
;
; ((%error-handler-cond kont () (ans-clause ...))
; (cond ans-clause ...))))

193
scheme/lib/htmlout.scm
View File

@ -1,193 +0,0 @@
;;; Simple code for doing structured html output. -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; Copyright (c) 1996 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; - An attribute-quoter, that will map an attribute value to its
;;; HTML text representation -- surrounding it with single or double quotes,
;;; as appropriate, etc.
;;; Printing HTML tags.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; All the emit-foo procedures have the same basic calling conventions:
;;; (emit-foo out <required values> ... [<extra attributes> ...])
;;; - OUT is either a port or #t for the current input port.
;;; - Each attribute is either a (name . value) pair, which is printed as
;;; name="value"
;;; or a single symbol or string, which is simply printed as-is
;;; (this is useful for attributes that don't have values, such as the
;;; ISMAP attribute in <img> tags).
;;; <tag name1="val1" name2="val2" ...>
(define (emit-tag out tag . attrs)
(let ((out (fmt->port out)))
(display "<" out)
(display tag out)
(for-each (lambda (attr)
(display #\space out)
(cond ((pair? attr) ; name="val"
(display (car attr) out)
(display "=\"" out) ; Should check for
(display (cdr attr) out) ; internal double-quote
(display #\" out)) ; etc.
(else
(display attr out)))) ; name
attrs)
(display #\> out)))
;;; </tag>
(define (emit-close-tag out tag)
(format out "</~a>" tag))
;;; <P>
(define (emit-p . args) ; (emit-p [out attr1 ...])
(receive (out attrs) (if (pair? args)
(let* ((out (car args)))
(values (if (eq? out #t) (current-output-port) out)
(cdr args)))
(values (current-output-port) args))
(apply emit-tag out 'p attrs)))
;;; <TITLE> Make Money Fast!!! </TITLE>
(define (emit-title out title) ; Takes no attributes.
(format out "<title>~a~%</title>~%" title))
(define (emit-header out level text . attribs)
(apply with-tag* out (string-append "H" (number->string level))
(lambda () (display text (fmt->port out)))
attribs))
;;; ...and so forth. Could stand to define a bunch of little emitters for the
;;; various tags. (define-tag-emitter ...)
;;; Printing out balanced <tag> ... </tag> pairs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (with-tag out tag (attr-elt ...) body ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Execute the body forms between a <tag attrs> ... </tag> pair.
;;; The (ATTR-ELT ...) list specifies the attributes for the <tag>.
;;; It is rather like a LET-list, having the form
;;; ((name val) ...)
;;; Each NAME must be a symbol, and each VAL must be a Scheme expression
;;; whose value is the string to use as attribute NAME's value. Attributes
;;; that have no value (e.g., ISMAP) can be specified as attr-elt NAME,
;;; instead of (NAME VALUE).
;;;
;;; For example,
;;; (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page.
;;; (with-tag port A ((href hp-url) (name "hp"))
;;; (display "home page" port)))
;;; outputs
;;; <A href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</A>
(define-syntax with-tag
(syntax-rules ()
((with-tag out tag (attr-elt ...) body ...)
(with-tag* out 'tag (lambda () body ...)
(%hack-attr-elt attr-elt)
...))))
;;; Why does this have to be top-level?
;;; Why can't this be a LET-SYNTAX inside of WITH-TAG?
(define-syntax %hack-attr-elt
(syntax-rules () ; Build attribute-list element:
((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt)
(cons 'name val))
((%hack-attr-elt name) 'name))) ; name => 'name
;;; Execute THUNK between a <tag attrs> ... </tag> pair.
(define (with-tag* out tag thunk . attrs)
(apply emit-tag out tag attrs)
(let ((out (fmt->port out)))
(call-with-values thunk
(lambda results
(emit-close-tag out tag)
(apply values results)))))
(define (fmt->port x)
(if (eq? x #t) (current-output-port) x))
;;; Translate text to HTML, mapping special chars such as <, >, &, and
;;; double-quote to their HTML escape sequences.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Note iso8859-1 above 127 is perfectly OK
(define *html-entity-alist*
(list
(cons (ascii->char 60) "&lt;")
(cons (ascii->char 62) "&gt;")
(cons (ascii->char 38) "&amp;")
(cons (ascii->char 34) "&quot;")))
(define *html-entities*
(list->char-set (map car *html-entity-alist*)))
(define *html-entity-table*
(let ((v (make-vector 256 #f)))
(for-each (lambda (entry)
(vector-set! v
(char->ascii (car entry))
(cdr entry)))
*html-entity-alist*)
v))
(define (string-set-substring! t start s)
(let* ((l (string-length s))
(end (+ l start)))
(do ((i start (+ 1 i)))
((= i end) t)
(string-set! t i (string-ref s (- i start))))))
(define (escape-html s)
(let ((target-length
(string-fold (lambda (c i)
(+ i
(if (char-set-contains? *html-entities* c)
(string-length
(vector-ref *html-entity-table*
(char->ascii c)))
1)))
0
s)))
(if (= target-length (string-length s))
s
(let ((target (make-string target-length)))
(string-fold
(lambda (c i)
(+ i
(if (char-set-contains? *html-entities* c)
(let ((entity (vector-ref *html-entity-table* (char->ascii c))))
(string-set-substring! target i entity)
(string-length entity))
(begin
(string-set! target i c)
1))))
0
s)
target))))
(define (emit-text s . maybe-port)
(if (null? maybe-port)
(write-string (escape-html s))
(write-string (escape-html s) (fmt->port (car maybe-port)))))

335
scheme/lib/ls.scm
View File

@ -1,335 +0,0 @@
; ls clone in scsh
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998 Michael Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
; This currently does a whole bunch of stats on every file in some
; cases. In a decent OS implementation, this stuff is cached, so
; there isn't any problem, at least not in theory :-)
; FLAGS is a list of symbols from:
;
; all - include stuff starting with "."
; recursive - guess what
; long - output interesting information per file
; directory - display only the information for the directory named
; flag - flag files as per their types
; columns - sorts output vertically in a multicolumn format
(define ls-crlf? (make-fluid #f))
(define (ls flags paths . maybe-port)
(let* ((port (optional maybe-port (current-output-port)))
(paths (if (null? paths)
(list (cwd))
paths))
(only-one? (null? (cdr paths))))
(call-with-values
(lambda () (parse-flags flags))
(lambda (all? recursive? long? directory? flag? columns?)
(real-ls paths
(if only-one? #f "")
all? recursive? long? directory? flag? columns?
port)))))
(define (parse-flags flags)
(let ((all? (memq 'all flags))
(recursive? (memq 'recursive flags))
(long? (memq 'long flags))
(directory? (memq 'directory flags))
(flag? (memq 'flag flags))
(columns? (memq 'columns flags)))
(values all? recursive? long? directory? flag? columns?)))
(define (real-ls paths prefix
all? recursive? long? directory? flag? columns?
port)
(let ((first #t))
(for-each
(lambda (path)
(if first
(set! first #f)
(ls-newline port))
(if prefix
(format port "~A~A:~%" prefix path))
(ls-path path all? recursive? long? directory? flag? columns? port))
paths)))
(define (ls-path path all? recursive? long? directory? flag? columns? port)
(cond
((and (not directory?) ;; go into directories
(or (and (file-name-directory? path) ;; path specifies directory
(file-directory? path #t)) ;; either as a symlink (if the names end with a slash)
(file-directory? path #f))) ;; or not
(ls-directory path all? recursive? long? directory? flag? columns? port))
(else
(if (or long? flag?) ;; see LS-DIRECTORY for details
(ls-file (cons path (file-info path #f)) long? flag? port)
(ls-file (cons path #f) long? flag? port)))))
(define (ls-directory directory all? recursive? long? directory? flag? columns? port)
; terminology: a FILE-NAME is the name of a file
; a FILE is a pair whose car is a file-name and whose cdr is
; either its file-info-object or #f (if not needed)
; a INFO is a file-info-object
(let* ((directory (file-name-as-directory directory))
(substantial-directory (string-append directory "."))
(file-names (directory-files substantial-directory all?)))
(with-cwd*
substantial-directory
(lambda ()
(let ((files (if (or recursive? long? flag?) ; these are the flags for which we need the file-info
(map (lambda (file-name)
(cons file-name (file-info file-name #f)))
file-names)
(map (lambda (file-name) (cons file-name #f))
file-names))))
(if (and (not long?)
columns?)
(ls-files-columns files flag? port)
(ls-files-column files long? flag? port))
(if recursive?
(let ((directories
(map (lambda (file) (car file))
(filter (lambda (file)
(eq? (file-info:type (cdr file)) 'directory))
files))))
(if (not (null? directories))
(begin
(ls-newline port)
(real-ls directories directory
all? recursive? long? directory? flag? columns?
port))))))))))
(define *width* 79)
(define (ls-files-columns files flag? port)
(let* ((max-file-name-width
(if (null? files)
0
(apply max (map (lambda (file) (string-length (car file))) files))))
(max-file-name-width
(if flag?
(+ 1 max-file-name-width)
max-file-name-width))
(column-width (+ 2 max-file-name-width))
(columns (quotient *width*
column-width))
(columns (if (zero? columns)
1
columns))
(number-of-files (length files))
(rows (quotient (+ number-of-files (- columns 1))
columns))
(tails
(do ((column 0 (+ 1 column))
(tails (make-vector columns)))
((= column columns)
tails)
(vector-set! tails column
(list-tail-or-null files (* rows column))))))
(do ((row 0 (+ 1 row)))
((= row rows))
(do ((column 0 (+ 1 column)))
((= column columns))
(let ((tail (vector-ref tails column)))
(if (not (null? tail))
(let* ((file (car tail))
(width (display-file file flag? port)))
(display-spaces (- column-width width) port)
(vector-set! tails column (cdr tail))))))
(ls-newline port))))
(define (list-tail-or-null list index)
(let loop ((list list) (index index))
(cond
((null? list) list)
((zero? index) list)
(else (loop (cdr list) (- index 1))))))
(define (ls-files-column files long? flag? port)
(for-each
(lambda (file)
(ls-file file long? flag? port))
files))
(define (ls-file file long? flag? port)
(if long?
(ls-file-long file flag? port)
(ls-file-short file flag? port)))
(define (ls-file-short file flag? port)
(display-file file flag? port)
(ls-newline port))
(define (ls-file-long file flag? port)
(let ((info (cdr file)))
(display-permissions info port)
(display-decimal-justified (file-info:nlinks info) 4 port)
(write-char #\space port)
(let* ((uid (file-info:uid info))
(user-name
(call-with-current-continuation
(lambda (escape)
(with-handler
(lambda (condition more)
(escape (number->string uid)))
(lambda ()
(user-info:name (user-info uid))))))))
(display-padded user-name 9 port))
(let* ((gid (file-info:gid info))
(group-name
(call-with-current-continuation
(lambda (escape)
(with-handler
(lambda (condition more)
(escape (number->string gid)))
(lambda ()
(group-info:name (group-info gid))))))))
(display-padded group-name 9 port))
(display-decimal-justified (file-info:size info) 7 port)
(write-char #\space port)
(display-time (file-info:mtime info) port)
(write-char #\space port)
(display-file file flag? port)
(if (eq? (file-info:type info) 'symlink)
(begin
(display " -> " port)
(display (read-symlink (car file)) port)))
(ls-newline port)))
(define *year-seconds* (* 365 24 60 60))
(define (display-time the-time port)
(let ((time-difference (abs (- (time) the-time)))
(date (date the-time 0)))
(if (< time-difference *year-seconds*)
(display (format-date "~b ~d ~H:~M" date) port)
(display (format-date "~b ~d ~Y " date) port))))
(define (display-file file flag? port)
(let ((file-name (car file)))
(display file-name port)
(if (maybe-display-flag (cdr file) flag? port)
(+ 1 (string-length file-name))
(string-length file-name))))
(define (maybe-display-flag info flag? port)
(and flag?
(begin
(cond
((eq? (file-info:type info) 'directory)
(write-char #\/ port))
((eq? (file-info:type info) 'symlink)
(write-char #\@ port))
; 'executable: bits 0, 3 or 6 are set:
; that means, 'AND' with 1+8+64=73 results in a nonzero-value
; note: there is no distinction between user's, group's and other's permissions
; (as the real GNU-ls does not)
((not (zero? (bitwise-and (file-info:mode info) 73)))
(write-char #\* port))
((eq? (file-info:type info) 'socket)
(write-char #\= port))
((eq? (file-info:type info) 'fifo)
(write-char #\| port)))
#t)))
(define (display-permissions info port)
(case (file-info:type info)
((directory)
(write-char #\d port))
((symlink)
(write-char #\l port))
((fifo)
(write-char #\p port))
(else
(write-char #\- port)))
(let ((mode (file-info:mode info))
(bit 8))
(for-each
(lambda (id)
(if (not (zero? (bitwise-and (arithmetic-shift 1 bit)
mode)))
(write-char id port)
(write-char #\- port))
(set! bit (- bit 1)))
'(#\r #\w #\x #\r #\w #\x #\r #\w #\x))))
(define (display-decimal-justified number width port)
(display-justified (number->string number) width port))
(define (display-justified string width port)
(let ((length (string-length string)))
(if (< length width)
(display-spaces (- width length) port))
(display string port)))
(define (display-padded string width port)
(let ((length (string-length string)))
(display string port)
(if (< length width)
(display-spaces (- width length) port))))
(define (display-spaces number port)
(do ((i 0 (+ 1 i)))
((= i number))
(write-char #\space port)))
;; Convert Unix-style arguments to flags suitable for LS.
(define (arguments->ls-flags args)
(let loop ((args args) (flags '()))
(if (null? args)
flags
(cond
((argument->ls-flags (car args))
=> (lambda (new-flags)
(loop (cdr args) (append new-flags flags))))
(else #f)))))
(define (argument->ls-flags arg)
(let ((arg (if (symbol? arg)
(symbol->string arg)
arg)))
(if (or (string=? "" arg)
(not (char=? #\- (string-ref arg 0))))
#f
(let loop ((chars (cdr (string->list arg))) (flags '()))
(cond
((null? chars)
flags)
((char->flag (car chars))
=> (lambda (flag)
(loop (cdr chars) (cons flag flags))))
(else #f))))))
(define (char->flag char)
(case char
((#\a) 'all)
((#\R) 'recursive)
((#\l) 'long)
((#\d) 'directory)
((#\F) 'flag)
((#\C) 'columns)
(else #f)))
(define (optional maybe-arg default-exp)
(cond
((null? maybe-arg) default-exp)
((null? (cdr maybe-arg)) (car maybe-arg))
(else (error "too many optional arguments" maybe-arg))))
(define (ls-newline port)
(if (fluid ls-crlf?)
(write-crlf port)
(newline port)))

155
scheme/lib/netrc.scm
View File

@ -1,155 +0,0 @@
;;; netrc.scm -- parse authentication information contained in ~/.netrc
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define (check-permissions file-name)
(if (not (zero? (bitwise-and #b000111111 (file-mode file-name))))
(error "Not parsing netrc file; dangerous permissions."
file-name)))
(define (netrc-file-name)
(string-append (file-name-as-directory (home-dir))
".netrc"))
(define (skip-whitespace port)
(let loop ()
(let ((char (peek-char port)))
(cond
((eof-object? char)
(values))
((char-set-contains? char-set:whitespace char)
(read-char port)
(loop))
(else (values))))))
(define (skip-until-eol port)
(let loop ()
(let ((char (peek-char port)))
(cond
((eof-object? char)
(values))
((char=? #\newline char)
(read-char port))
(else
(read-char port)
(loop))))))
(define (read-lines-until-double-eol port)
(let loop ((reverse-lines '()))
(let ((line (read-line port)))
(if (or (eof-object? line)
(string=? "" line))
(reverse reverse-lines)
(loop (cons line reverse-lines))))))
(define (next-token port)
(skip-whitespace port)
(let loop ((reverse-chars '()))
(define (token)
(if (null? reverse-chars)
#f
(list->string (reverse reverse-chars))))
(let ((char (peek-char port)))
(cond
((eof-object? char) (token))
((char-set-contains? char-set:whitespace char) (token))
(else
(loop (cons (read-char port) reverse-chars)))))))
(define (next-field port)
(let ((token (next-token port)))
(cond
((not token)
(values #f #f))
((string=? "default" token)
(values token #f))
((string=? "macdef" token)
(let ((name (next-token port)))
(skip-until-eol port)
(values token
(cons name (read-lines-until-double-eol port)))))
(else
(values token (next-token port))))))
(define (skip-until-machine port machine accept-default?)
(let loop ()
(call-with-values
(lambda () (next-field port))
(lambda (tag value)
(cond
((not tag) #f)
((and accept-default? (string=? "default" tag))
#t)
((and (string=? tag "machine")
(string-ci=? machine value))
#t)
(else
(loop)))))))
(define (next-macro-definition port)
(let loop ()
(call-with-values
(lambda () (next-field port))
(lambda (tag value)
(cond
((not tag) #f)
((string=? "macdef" tag) value)
(else (loop)))))))
(define-record-type netrc-entry :netrc-entry
(make-netrc-entry machine login password account)
netrc-entry?
(machine netrc-entry-machine set-netrc-entry-machine!)
(login netrc-entry-login set-netrc-entry-login!)
(password netrc-entry-password set-netrc-entry-password!)
(account netrc-entry-account set-netrc-entry-account!))
(define (netrc-machine-entry machine accept-default? . maybe-file-name)
(let ((file-name (if (pair? maybe-file-name)
(car maybe-file-name)
(netrc-file-name)))
(entry (make-netrc-entry machine #f #f #f)))
(check-permissions file-name)
(call-with-input-file file-name
(lambda (port)
(if (not (skip-until-machine port machine accept-default?))
#f
(let loop ()
(call-with-values
(lambda () (next-field port))
(lambda (tag value)
(cond
((not tag) entry)
((or (string=? "default" tag)
(string=? "machine" tag))
entry)
((string=? "login" tag)
(set-netrc-entry-login! entry value)
(loop))
((string=? "password" tag)
(set-netrc-entry-password! entry value)
(loop))
((string=? "account" tag)
(set-netrc-entry-account! entry value)
(loop))
(else (loop)))))))))))
(define (netrc-macro-definitions . maybe-file-name)
(let ((file-name (if (pair? maybe-file-name)
(car maybe-file-name)
(netrc-file-name))))
(check-permissions file-name)
(call-with-input-file file-name
(lambda (port)
(let loop ((reverse-alist '()))
(cond
((next-macro-definition port)
=> (lambda (pair)
(loop (cons pair reverse-alist))))
(else (reverse reverse-alist))))))))

111
scheme/lib/nettime.scm
View File

@ -1,111 +0,0 @@
;;; nettime.scm -- obtain the time on remote machines
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998 by Eric Marsden
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; Related work ======================================================
;;
;; * Time.pm is a Perl module by Graham Barr
;; * rfc868 describes the Time protocol
;; http://www.ietf.org/rfc/rfc868.txt
;; * rfc867 describes the Daytime protocol in all its glory
;; http://www.ietf.org/rfc/rfc867.txt
;; * for a genuinely useful protocol look at the Network Time Protocol
;; defined in rfc1305, which allows for the synchronization of clocks
;; on networked computers.
;; args host protocol, where host may be an IP number or a fqdn. we
;; subtract 70 years' worth of seconds at the end, since the time
;; protocol returns the number of seconds since 1900, whereas Unix
;; time is since 1970.
(define (rfc868-time/tcp host)
(let* ((hst-info (host-info host))
(srvc-info (service-info "time" "tcp"))
(sock (socket-connect protocol-family/internet
socket-type/stream
(host-info:name hst-info)
(service-info:port srvc-info)))
(result (read-integer (socket:inport sock))))
(close-socket sock)
(- result 2208988800)))
(define (rfc868-time/udp host . maybe-timeout)
(let* ((hst-info (host-info host))
(srvc-info (service-info "time" "udp"))
(timeout (if (pair? maybe-timeout)
(car maybe-timeout)
#f))
(socket (create-socket protocol-family/internet socket-type/datagram)))
(connect-socket socket
(internet-address->socket-address
(car (host-info:addresses hst-info))
(service-info:port srvc-info)))
(send-message socket "")
(if (null? (select-ports timeout (socket:inport socket)))
(begin
(close-socket socket)
#f)
(with-fatal-error-handler*
(lambda (result punt)
;; we may see a "connection refused" error here
#f)
(lambda ()
(let ((result (read-integer (socket:inport socket))))
(close-socket socket)
(- result 2208988800)))))))
(define (rfc867-daytime/tcp host)
(let* ((hst-info (host-info host))
(srvc-info (service-info "daytime" "tcp"))
(sock (socket-connect protocol-family/internet
socket-type/stream
(host-info:name hst-info)
(service-info:port srvc-info)))
(result (read-string 20 (socket:inport sock))))
(close-socket sock)
result))
(define (rfc867-daytime/udp host . maybe-timeout)
(let* ((hst-info (host-info host))
(srvc-info (service-info "daytime" "udp"))
(timeout (if (pair? maybe-timeout)
(car maybe-timeout)
#f))
(socket (create-socket protocol-family/internet socket-type/datagram)))
(connect-socket socket
(internet-address->socket-address
(car (host-info:addresses hst-info))
(service-info:port srvc-info)))
(send-message socket "")
(if (null? (select-ports timeout (socket:inport socket)))
(begin
(close-socket socket)
#f)
(with-fatal-error-handler*
(lambda (result punt)
;; we may see a "connection refused" error here
#f)
(lambda ()
(call-with-values
(lambda () (receive-message socket 20))
(lambda (result socket-address)
(close-socket socket)
result)))))))
;; read 4 bytes from fd and build an integer from them
(define (read-integer fd)
(let loop ((accum 0)
(remaining 4))
(if (zero? remaining)
accum
(loop (+ (arithmetic-shift accum 8) (read-byte fd))
(- remaining 1)))))
;; what about EOF??
(define (read-byte fd)
(char->ascii (read-char fd)))

57
scheme/lib/parse-forms.scm
View File

@ -1,57 +0,0 @@
;;; Code to parse information submitted from HTML forms. -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html
;;; About HTML forms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The form's field data are turned into a single string, of the form
;;; name=val&name=val
;;; where the <name> and <val> parts are URI encoded to hide their
;;; &, =, and + chars, among other things. After URI encoding, the
;;; space chars are converted to + chars, just for fun. It is important
;;; to encode the spaces this way, because the perfectly general %xx escape
;;; mechanism might be insufficiently confusing. This variant encoding is
;;; called "form-url encoding."
;;;
;;; If the form's method is POST,
;;; Browser sends the form's field data in the entity block, e.g.,
;;; "button=on&ans=yes". The request's Content-type: is application/
;;; x-www-form-urlencoded, and the request's Content-length: is the
;;; number of bytes in the form data.
;;;
;;; If the form's method is GET,
;;; Browser sends the form's field data in the URL's <search> part.
;;; (So the server will pass to the CGI script as $QUERY_STRING,
;;; and perhaps also on in argv[]).
;;;
;;; In either case, the data is "form-url encoded" (as described above).
(define (parse-html-form-query q)
(let ((qlen (string-length q)))
(let recur ((i 0))
(cond
((>= i qlen) '())
((string-index q #\= i) =>
(lambda (j)
(let ((k (or (string-index q #\& j) qlen)))
(cons (cons (unescape-uri+ q i j)
(unescape-uri+ q (+ j 1) k))
(recur (+ k 1))))))
(else '()))))) ; BOGUS STRING -- Issue a warning.
;;; Map plus characters to spaces, then do URI decoding.
(define (unescape-uri+ s . maybe-start/end)
(let-optionals maybe-start/end ((start 0)
(end (string-length s)))
(unescape-uri (string-map (lambda (c) (if (char=? c #\+) #\space c))
(if (and (zero? start)
(= end (string-length s)))
s ; Gratuitous optimisation.
(substring s start end))))))

290
scheme/lib/pop3.scm
View File

@ -1,290 +0,0 @@
;;; pop3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1998 by Eric Marsden
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; Related work =====================================================
;;
;; * Emacs is distributed with a C program called movemail which can
;; be compiled with support for the POP protocol. There is also an
;; Emacs Lisp library called pop3.el by Richard Pieri which includes
;; APOP support.
;;
;; * Shriram Krishnamurthi has written a POP3 library for MzScheme (as
;; well as support for the NNTP protocol, for SMTP, ...).
;;
;; * Siod (a small-footprint Scheme implementation by George Carette)
;; includes support for the POP3 protocol.
;;
;; * rfc1939 describes the POP3 protocol.
;; http://www.ietf.org/rfc/rfc1939.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Communication is initiated by the client. The server responds to
;; each request with a status indicator and an explanatory message.
;; The client starts off by opening a connection to a well known port
;; on the server machine (typically TCP 110, or 109 on some broken
;; systems). Messages sent to the server are of the form
;;
;; CMD [ <space> arg ] <CR> <LF>
;;
;; Replies from the server are of the form
;;
;; status [ <space> Informative message ] <CR> <LF>
;;
;; where status is either "+OK" or "-ERR". If the server is sending
;; data (the contents of a message for example), it marks the end of
;; the data by a line consisting only of a decimal point (thus the
;; bytes to look out for are <CR><LF>.<CR><LF>. Any lines in the data
;; starting with a . have an additional . added to the beginning, to
;; avoid the client thinking that the line marks the end of the
;; message. The client should therefore replace double decimal points
;; at the beginning of a line by a single decimal point.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (pop3-connect . args)
(let-optionals args ((host-arg #f)
(login #f)
(password #f)
(log #f))
(let* ((host (or host-arg
(getenv "MAILHOST")))
(hst-info (host-info host))
(hostname (host-info:name hst-info))
(srvc-info (service-info "pop3" "tcp"))
(sock (socket-connect protocol-family/internet
socket-type/stream
hostname
(service-info:port srvc-info)))
(connection (make-pop3-connection hostname
sock
log "" "" #f #f)))
(pop3-log connection
(string-append "-- "
(date->string (date))
": opened POP3 connection to "
hostname))
;; read the challenge the server sends in its welcome banner
(let* ((banner (read-response connection))
(match (regexp-search (rx (: "+OK " (* (~ #\<))
#\< (submatch (+ (~ #\>))) #\>))
banner))
(challenge (and match (match:substring match 1))))
(set-pop3-connection-challenge! connection challenge))
(pop3-login connection login password)
connection)))
;; first try standard USER/PASS authentication, and switch to APOP
;; authentication if the server prefers.
(define (pop3-login connection login password)
(let* ((netrc-record #f)
(get-netrc-record
(lambda ()
(cond
(netrc-record)
(else
(set! netrc-record
(netrc-machine-entry (pop3-connection-host-name connection) #f))
netrc-record)))))
(let ((login (or login
(begin
(if (or (not (get-netrc-record))
(not (netrc-entry-login (get-netrc-record))))
(signal 'pop3-error
"no login record specified and no netrc entry"))
(netrc-entry-login (get-netrc-record)))))
(password (or password
(begin
(if (not (netrc-entry-password (get-netrc-record)))
(signal 'pop3-error
"no password record specified and no netrc entry"))
(netrc-entry-password (get-netrc-record))))))
(with-fatal-error-handler*
(lambda (result punt)
(cond
((not (pop3-error? result)) (punt))
((pop3-connection-challenge connection)
(pop3-apop-login connection login password))))
(lambda ()
(send-command connection (build-command "USER" login))
(send-command connection (build-command "PASS" password))
(set-pop3-connection-login! connection login)
(set-pop3-connection-password! connection password)
(set-pop3-connection-state! connection 'connected))))))
;; Login to the server using APOP authentication (no cleartext
;; passwords are sent over the network). The server appends a token to
;; its welcome message, which is built from the server's fully
;; qualified domain name and a unique serial number. The client
;; concatenates this token and the pass phrase and applies the MD5
;; digest algorithm (a one-way hash) to produce a digest. The user
;; name and the digest are sent to the server to authenticate the
;; user. The following example comes from the RFC:
;;
;; S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us>
;; C: APOP mrose c4c9334bac560ecc979e58001b3e22fb
;; S: +OK maildrop has 1 message (369 octets)
;;
;; In this example, the shared secret is the string `tan-
;; staaf'. Hence, the MD5 algorithm is applied to the string
;;
;; <1896.697170952@dbc.mtview.ca.us>tanstaaf
;;
;; which produces a digest value of
;;
;; c4c9334bac560ecc979e58001b3e22fb
;;
(define (pop3-apop-login connection login password)
(let* ((key (string-append (pop3-connection-challenge connection)
password))
(digest (number->string
(md5-digest->number (md5-digest-for-string key))
16))
(status (send-command connection
(build-command "APOP" login digest))))
(set-pop3-connection-login! connection login)
(set-pop3-connection-password! connection password)
(set-pop3-connection-state! connection 'connected)
status))
;; return number of messages and number of bytes waiting at the maildrop
(define (pop3-stat connection)
(check-transaction-state connection pop3-stat)
(let* ((response (send-command connection "STAT"))
(match (regexp-search (rx (posix-string "([0-9]+) ([0-9]+)")) response)))
(values (string->number (match:substring match 1))
(string->number (match:substring match 2)))))
(define (pop3-retrieve-message connection msgid)
(check-transaction-state connection pop3-retrieve-message)
(let* ((status (send-command connection
(build-command "RETR" (number->string msgid))))
(port (socket:inport (pop3-connection-command-socket connection)))
(headers (read-rfc822-headers port read-crlf-line))
(body (multiline-response->lines port)))
(values headers body)))
(define (pop3-retrieve-headers connection msgid)
(check-transaction-state connection pop3-retrieve-headers)
(let* ((status (send-command connection
(build-command "TOP" (number->string msgid) "0")))
(port (socket:inport (pop3-connection-command-socket connection)))
(headers (read-rfc822-headers port read-crlf-line)))
(exhaust-multiline-response port)
headers))
;; Return highest accessed message-id number for the session. This
;; ain't in the RFC, but seems to be supported by several servers.
(define (pop3-last connection)
(check-transaction-state connection pop3-last)
(let ((response (send-command connection "LAST")))
(string->number (car ((infix-splitter) response)))))
;; mark the message number MSGID for deletion. Note that the messages
;; are not truly deleted until the QUIT command is sent, and messages
;; can be undeleted using the RSET command.
(define (pop3-delete connection msgid)
(check-transaction-state connection pop3-delete)
(send-command connection (build-command "DELE" (number->string msgid)))
(values))
;; any messages which have been marked for deletion are unmarked
(define (pop3-reset connection)
(check-transaction-state connection pop3-reset)
(send-command connection "RSET")
(values))
(define (pop3-quit connection)
(check-transaction-state connection pop3-quit)
(let ((status (send-command connection "QUIT")))
(close-socket (pop3-connection-command-socket connection))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Nothing exported below.
(define-record-type pop3-connection :pop3-connection
(make-pop3-connection host-name command-socket log-port login password challenge state)
pop3-connection?
(host-name pop3-connection-host-name)
(command-socket pop3-connection-command-socket)
(log-port pop3-connection-log-port)
(login pop3-connection-login set-pop3-connection-login!)
(password pop3-connection-password set-pop3-connection-password!)
(challenge pop3-connection-challenge set-pop3-connection-challenge!)
(state pop3-connection-state set-pop3-connection-state!))
(define-condition-type 'pop3-error '(error))
(define pop3-error? (condition-predicate 'pop3-error))
(define (check-transaction-state connection caller)
(if (not (eq? (pop3-connection-state connection) 'connected))
(error "not in transaction state" caller)))
(define (read-response connection)
(let* ((sock (pop3-connection-command-socket connection))
(in (socket:inport sock))
(line (read-crlf-line in)))
(pop3-log connection (string-append "-> " line))
line))
;; this could perhaps be improved
(define (handle-response response command)
(let ((match (regexp-search (rx (posix-string "^\\+OK(.*)")) response)))
(if match
(match:substring match 1)
(let ((match2 (regexp-search (rx (posix-string "^-ERR(.*)")) response)))
(if match2
(signal 'pop3-error (match:substring match2 1) command)
(signal 'pop3-error response command))))))
(define (pop3-log connection line)
(let ((log (pop3-connection-log-port connection)))
(if log
(begin
(write-string line log)
(newline log)
(force-output log)))))
(define (send-command connection command)
(let* ((sock (pop3-connection-command-socket connection))
(out (socket:outport sock)))
(write-string command out)
(write-crlf out)
(pop3-log connection (string-append "<- " command))
(handle-response (read-response connection) command)))
(define (multiline-response->lines port)
(let loop ((reverse-lines '()))
(let ((line (read-crlf-line port)))
(if (and (not (eof-object? line))
(not (string=? line ".")))
(let ((line (if (string-prefix? ".." line)
(substring line 1 (string-length line))
line)))
(loop (cons line reverse-lines)))
(reverse reverse-lines)))))
(define (exhaust-multiline-response port)
(let loop ()
(let ((line (read-crlf-line port)))
(if (and (not (eof-object? line))
(not (string=? line ".")))
(loop)))))
(define (build-command str . opt-args)
(string-join (cons str opt-args)))

63
scheme/lib/rate-limit.scm
View File

@ -1,63 +0,0 @@
;;; Rate limiting -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define-record-type rate-limiter :rate-limiter
(really-make-rate-limiter simultaneous-requests
access-lock
block-lock
current-requests)
rate-limiter?
(simultaneous-requests rate-limiter-simultaneous-requests)
(access-lock rate-limiter-access-lock)
(block-lock rate-limiter-block-lock)
(current-requests rate-limiter-current-requests-unsafe
set-rate-limiter-current-requests!))
(define (make-rate-limiter simultaneous-requests)
(really-make-rate-limiter simultaneous-requests
(make-lock)
(make-lock)
0))
(define (rate-limit-block rate-limiter)
(obtain-lock (rate-limiter-block-lock rate-limiter)))
(define (rate-limit-open rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(+ 1 (rate-limiter-current-requests-unsafe rate-limiter))))
(set-rate-limiter-current-requests! rate-limiter
current-requests)
(if (>= current-requests
(rate-limiter-simultaneous-requests rate-limiter))
(maybe-obtain-lock (rate-limiter-block-lock rate-limiter))
(release-lock (rate-limiter-block-lock rate-limiter))))
(release-lock (rate-limiter-access-lock rate-limiter)))
(define (rate-limit-close rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(- (rate-limiter-current-requests-unsafe rate-limiter) 1)))
(if (negative? current-requests)
(error "rate-limiter: too many close operations"
rate-limiter))
(set-rate-limiter-current-requests! rate-limiter
current-requests)
(if (= current-requests
(- (rate-limiter-simultaneous-requests rate-limiter)
1))
;; we just came back into range
(release-lock (rate-limiter-block-lock rate-limiter))))
(release-lock (rate-limiter-access-lock rate-limiter)))
(define (rate-limiter-current-requests rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(rate-limiter-current-requests-unsafe rate-limiter)))
(release-lock (rate-limiter-access-lock rate-limiter))
current-requests))

113
scheme/lib/rfc822.scm
View File

@ -1,113 +0,0 @@
;;; RFC 822 field-parsing code
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers <shivers@lcs.mit.edu>
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; RFC 822 is the "Standard for the format of ARPA Internet text messages"
;;; -- the document that essentially tells how the fields in email headers
;;; (e.g., the Subject: and To: fields) are formatted. This code is for
;;; parsing these headers.
;;; Here is a pointer to the document:
;;; http://www.ietf.org/rfc/rfc0822.txt
;;; RFC 822 parsing is useful in other contexts as well -- the HTTP protocol
;;; uses it, and it tends to pop up here and there.
;;;
;;; RFC 822 header syntax has two levels: the general syntax for headers,
;;; and the syntax for specific headers. For example, once you have figured
;;; out which chunk of text is the To: line, there are more rules telling
;;; how to split the To: line up into a list of addresses. Another example:
;;; lines with dates, e.g., the Date: header, have a specific syntax for
;;; the time and date.
;;;
;;; This code currently *only* provides routines for parsing the gross
;;; structure -- splitting the message header into its distinct fields.
;;; It would be nice to provide the finer-detail parsers, too. You do it.
;;; -Olin
;;; A note on line-terminators:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Line-terminating sequences are always a drag, because there's no agreement
;;; on them -- the Net protocols and DOS use cr/lf; Unix uses lf; the Mac
;;; uses cr. One one hand, you'd like to use the code for all of the above,
;;; on the other, you'd also like to use the code for strict applications
;;; that need definitely not to recognise bare cr's or lf's as terminators.
;;;
;;; RFC 822 requires a cr/lf (carriage-return/line-feed) pair to terminate
;;; lines of text. On the other hand, careful perusal of the text shows up
;;; some ambiguities (there are maybe three or four of these, and I'm too
;;; lazy to write them all down). Furthermore, it is an unfortunate fact
;;; that many Unix apps separate lines of RFC 822 text with simple linefeeds
;;; (e.g., messages kept in /usr/spool/mail). As a result, this code takes a
;;; broad-minded view of line-terminators: lines can be terminated by either
;;; cr/lf or just lf, and either terminating sequence is trimmed.
;;;
;;; If you need stricter parsing, you can pass a read-line procedure
;;; as an extra parameter. This means that you can pass in a procedure
;;; that recognizes only cr/lf's, or only cr's (for a Mac app,
;;; perhaps), and you can determine whether or not the terminators get
;;; trimmed. However, your read-line procedure must indicate the
;;; header-terminating empty line by returning *either* the empty
;;; string or the two-char string cr/lf (or the EOF object).
(define htab (ascii->char 9))
;;; Convert to a symbol using the Scheme implementation's preferred case,
;;; so we can compare these things against quoted constants.
(define string->symbol-pref
(if (char=? #\a (string-ref (symbol->string 'a) 0)) ; Is it #\a or #\A?
(lambda (s) (string->symbol (string-map char-downcase s)))
(lambda (s) (string->symbol (string-map char-upcase s)))))
(define (read-rfc822-field . args)
(receive (field body)
(apply read-rfc822-field-with-line-breaks args)
(values field
(string-concatenate body))))
(define (read-rfc822-field-with-line-breaks . args)
(let-optionals args ((port (current-input-port))
(read-line read-crlf-line))
(let ((line1 (read-line port)))
(if (or (eof-object? line1)
(zero? (string-length line1))
(string=? line1 "\r\n")) ; In case read-line doesn't trim.
(values #f #f)
(cond
((string-index line1 #\:) =>
(lambda (colon)
(let ((name (string->symbol-pref (substring line1 0 colon))))
;; Read in continuation lines.
(let lp ((lines (list (substring line1
(+ colon 1)
(string-length line1)))))
(let ((c (peek-char port)))
;; RFC822: continuous lines has to start with a space or a htab
(if (or (eqv? c #\space) (eqv? c htab))
(lp (cons (read-line port) lines))
(values name (reverse lines))))))))
(else (error "Illegal RFC 822 field syntax." line1))))))) ; No :
(define (make-read-rfc822-headers read-field)
(lambda args
(let-optionals args ((port (current-input-port))
(read-line read-crlf-line))
(let lp ((alist '()))
(receive (field val)
(read-rfc822-field port read-line)
(if field
(lp (cons (cons field val) alist))
(reverse alist)))))))
(define read-rfc822-headers
(make-read-rfc822-headers read-rfc822-field))
(define read-rfc822-headers-with-line-breaks
(make-read-rfc822-headers read-rfc822-field-with-line-breaks))
(define (rfc822-time->string time)
(format-date " ~a, ~d ~b ~Y ~H:~M:~S GMT" (date time 0)))

493
scheme/lib/smtp.scm
View File

@ -1,493 +0,0 @@
;;; SMTP client code -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 2002-2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; See rfc821: http://www.ietf.org/rfc/rfc0821.txt
;;; SMTP protocol procedures tend to return two values:
;;; - CODE The integer SMTP reply code returned by server for the transaction.
;;; - TEXT A list of strings -- the text messages tagged by the code.
;;; The text strings have the initial code numerals and the terminating
;;; cr/lf's stripped. Codes in the range [1,399] are sucess codes; codes
;;; in the range [400,599] are error codes; codes >= 600 are not part
;;; of the official SMTP spec. This module uses codes >= 600 to indicate
;;; extra-protocol errors. There are two of these:
;;; - 600 Server reply could not be parsed.
;;; The server sent back some sort of incomprehensible garbage reply.
;;; - 621 Premature EOF while reading server reply.
;;; The server shut down in the middle of a reply.
;;; A list of the official protocol return codes is appended at the end of
;;; this file.
;;; These little cover functions are trivial packagings of the protocol.
;;; You could write your own to handle, e.g., mailing a message to a list
;;; of addresses.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-condition-type 'smtp-error '(error))
(define smtp-error? (condition-predicate 'smtp-error))
(define-condition-type 'smtp-recipients-rejected-error '(smtp-error))
(define smtp-recipients-rejected-error?
(condition-predicate 'smtp-recipients-rejected-error?))
(define (smtp-send-mail from to-list headers body . maybe-host)
(let* ((host (:optional maybe-host "localhost"))
(local (if (string=? host "localhost")
(system-name) ; we don't need any DNS for that
(system-fqdn)))
(connection (smtp-connect host)))
(receive (code text)
(smtp-transactions/no-close connection ; Do prologue.
(smtp-helo local)
(smtp-mail from))
(if (>= code 400)
(begin
(smtp-quit (smtp-connection-socket connection))
(signal 'smtp-error code text))
;; Send over recipients and collect the losers.
(let ((losers (filter-map
(lambda (to)
(receive (code text)
((smtp-rcpt to) (smtp-connection-socket connection))
(and (>= code 400) ; Error
(cond ((>= code 600)
(smtp-quit
(smtp-connection-socket connection))
(signal 'smtp-error code text))
(else `(,to ,code ,@text))))))
to-list)))
;; Send the message body and wrap things up.
(receive (code text)
(smtp-transactions connection
(smtp-data (normalize-headers headers) body))
(if (or (>= code 400)
(not (null? losers)))
(signal 'smtp-recipients-rejected-error 700 losers))))))))
(define (normalize-headers headers)
(if (assq 'date headers)
headers
(cons (cons 'date
(rfc822-time->string (time)))
headers)))
(define (smtp-query socket query arg)
(receive (code text)
(smtp-transactions socket
(smtp-helo (system-name))
(query arg))
(values code text)))
(define (smtp-expand name host)
(smtp-query (smtp-connect host) smtp-expn name))
(define (smtp-verify name host)
(smtp-query (smtp-connect host) smtp-vrfy name))
(define (smtp-get-help host . details)
(smtp-query (smtp-connect host) smtp-help (apply string-append (cons " " details))))
(define (smtp-transactions connection . transactions)
(let ((socket (smtp-connection-socket connection)))
(receive (code text) (apply smtp-transactions/no-close connection transactions)
(cond
((or (= code 221)
(= code 421))
(values))
(else
(smtp-quit socket)))
(values code text))))
(define (smtp-transactions/no-close connection . transactions)
(let loop ((transactions transactions))
(receive (code text) ((car transactions) (smtp-connection-socket connection))
(if (or (null? (cdr transactions))
(= code 221)
(= code 421) ; Redundant, I know.
(<= 400 code))
(values code text)
(loop (cdr transactions))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The basics of the protocol
(define (nullary-smtp-command command)
(lambda (socket)
(let ((port (socket:outport socket)))
(write-string command port)
(write-crlf port))
(handle-smtp-reply socket)))
(define (unary-smtp-command command)
(lambda (data)
(lambda (socket)
(let ((port (socket:outport socket)))
(write-string command port)
(display #\space port)
(write-string data port)
(write-crlf port))
(handle-smtp-reply socket))))
(define-record-type smtp-connection :smtp-connection
(make-smtp-connection socket)
smtp-connection?
(socket smtp-connection-socket))
(define (smtp-connect host . maybe-port)
(let ((sock (socket-connect protocol-family/internet socket-type/stream host
(:optional maybe-port "smtp"))))
(receive (code text) (handle-smtp-reply sock)
(if (< code 400)
(make-smtp-connection sock)
(error "SMTP socket-open server-reply error" sock code text)))))
;; HELLO <local-hostname>
(define smtp-helo (unary-smtp-command "HELO"))
;; MAIL FROM: <sender-address>
(define smtp-mail (unary-smtp-command "MAIL FROM:"))
;; RECIPIENT TO: <destination-address>
(define smtp-rcpt (unary-smtp-command "RCPT TO:"))
;; DATA
(define smtp-data
(let ((send-DATA-msg (nullary-smtp-command "DATA")))
(lambda (headers message) ; MESSAGE is a list of strings or an input port.
(lambda (socket)
(receive (code text) (send-DATA-msg socket)
(if (>= code 400)
(values code text) ; Error.
;; We got a positive acknowledgement for the DATA msg,
;; now send the message body.
(let ((p (socket:outport socket)))
(for-each (lambda (pair)
(display (symbol->field-name (car pair)) p)
(write-char #\: p)
(display (cdr pair) p)
(write-crlf p))
headers)
(write-crlf p)
(cond ((or (null? message) (pair? message))
(for-each (lambda (line)
(write-data-line line p))
message))
((input-port? message)
(let lp ()
(let ((stuff (read-line message)))
(if (not (eof-object? stuff))
(begin
(write-data-line stuff p)
(newline))))))
(else (error "Message must be string or input-port.")))
(write-crlf p)
(write-char #\. p)
(write-crlf p)
(force-output p)
(handle-smtp-reply socket))))))))
(define component-charset (char-set-complement (char-set #\-)))
(define (symbol->field-name symbol)
(let ((components (string-tokenize (symbol->string symbol) component-charset)))
(string-join (map upcase-string components) "-")))
(define (upcase-string strng)
(if (string=? "" strng)
""
(string-append (string (char-upcase (string-ref strng 0)))
(substring strng 1 (string-length strng)))))
(define (write-data-line line port)
(display (if (string=? line ".")
".."
line)
port)
(write-crlf port))
;; SEND FROM: <sender-address>
(define smtp-send (unary-smtp-command "SEND FROM:"))
;; SEND OR MAIL <sender-address>
(define smtp-soml (unary-smtp-command "SOML FROM:"))
;; SEND AND MAIL <sender-address>
(define smtp-saml (unary-smtp-command "SOML SAML:"))
;; RESET
(define smtp-rset (nullary-smtp-command "RSET"))
;; VERIFY <user>
(define smtp-vrfy (unary-smtp-command "VRFY"))
;; EXPAND <user>
(define smtp-expn (unary-smtp-command "EXPN"))
;; HELP <details>
(define smtp-help
(let ((send-help (unary-smtp-command "HELP")))
(lambda details
(send-help (apply string-append details)))))
;; NOOP
(define smtp-noop (nullary-smtp-command "NOOP"))
;; QUIT
(define smtp-quit
(let ((quit (nullary-smtp-command "QUIT")))
(lambda (socket)
(receive (code text) (quit socket) ; Quit & close socket gracefully.
(case code
((221 421))
(else (close-socket socket))) ; But close in any event.
(values code text)))))
;; TURN
(define smtp-turn (nullary-smtp-command "TURN"))
;;; Read and handle the reply. Return an integer (the reply code),
;;; and a list of the text lines that came tagged by the reply code.
;;; The text lines have the reply-code prefix (first 4 chars) and the
;;; terminating cr/lf's stripped.
;;;
;;; In bdc's analog of this proc, he would read another reply if the code was
;;; in the one-hundred range (1xx). These codes aren't even used in smtp,
;;; according to the RFC. So why?
(define (handle-smtp-reply socket)
(receive (code text) (read-smtp-reply (socket:inport socket))
(case code
((221 421) (close-socket socket))) ; All done.
(values code text)))
;;; Read a reply from the SMTP server. Returns two values:
;;; - CODE Integer. The reply code.
;;; - TEXT String list. A list of the text lines comprising the reply.
;;; Each line of text is stripped of the initial reply-code
;;; numerals (e.g., the first four chars of the reply), and
;;; the trailing cr/lf. We are in fact generous about what
;;; we take to be a line -- the protocol requires cr/lf
;;; terminators, but we'll accept just lf. This appears to
;;; true to the spirit of the "be strict in what you send,
;;; and generous in what you accept" Internet protocol philosphy.
(define (read-smtp-reply port)
(let lp ((replies '()))
(let ((ln (read-crlf-line port)))
(if (eof-object? ln)
(values 621 (cons "Premature EOF during smtp reply."
(reverse replies)))
(receive (code line more?) (parse-smtp-reply ln)
(let ((replies (cons line replies)))
(if more?
(lp replies)
(values code (reverse replies)))))))))
;;; Parse a line of SMTP reply. Return three values:
;;; CODE integer - the reply code that prefixes the string.
;;; REST string - the rest of the line.
;;; MORE? boolean - is there more reply to read (i.e., was the numeric
;;; reply code terminated by a "-" character?)
(define (parse-smtp-reply line)
(if (and (string? line) ; This is all checking
(> (string-length line) 3) ; to see if the line
(char-numeric? (string-ref line 0)) ; is properly formatted.
(char-numeric? (string-ref line 1))
(char-numeric? (string-ref line 2))
(let ((c (string-ref line 3)))
(or (char=? c #\space) (char=? c #\-))))
(values (string->number (substring line 0 3)) ; It is.
(substring line 4 (string-length line))
(char=? (string-ref line 3) #\-))
(values 600 ; It isn't.
(string-append "Improperly-formatted smtp reply: " line)
#f)))
;;; Reply codes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This material taken from the RFC.
;;;
;;; 1yz Positive Preliminary reply
;;;
;;; The command has been accepted, but the requested action
;;; is being held in abeyance, pending confirmation of the
;;; information in this reply. The sender-SMTP should send
;;; another command specifying whether to continue or abort
;;; the action.
;;;
;;; [Note: SMTP does not have any commands that allow this
;;; type of reply, and so does not have the continue or
;;; abort commands.]
;;;
;;; 2yz Positive Completion reply
;;;
;;; The requested action has been successfully completed. A
;;; new request may be initiated.
;;;
;;; 3yz Positive Intermediate reply
;;;
;;; The command has been accepted, but the requested action
;;; is being held in abeyance, pending receipt of further
;;; information. The sender-SMTP should send another command
;;; specifying this information. This reply is used in
;;; command sequence groups.
;;;
;;; 4yz Transient Negative Completion reply
;;;
;;; The command was not accepted and the requested action did
;;; not occur. However, the error condition is temporary and
;;; the action may be requested again. The sender should
;;; return to the beginning of the command sequence (if any).
;;; It is difficult to assign a meaning to "transient" when
;;; two different sites (receiver- and sender- SMTPs) must
;;; agree on the interpretation. Each reply in this category
;;; might have a different time value, but the sender-SMTP is
;;; encouraged to try again. A rule of thumb to determine if
;;; a reply fits into the 4yz or the 5yz category (see below)
;;; is that replies are 4yz if they can be repeated without
;;; any change in command form or in properties of the sender
;;; or receiver. (E.g., the command is repeated identically
;;; and the receiver does not put up a new implementation.)
;;;
;;; 5yz Permanent Negative Completion reply
;;;
;;; The command was not accepted and the requested action did
;;; not occur. The sender-SMTP is discouraged from repeating
;;; the exact request (in the same sequence). Even some
;;; "permanent" error conditions can be corrected, so the
;;; human user may want to direct the sender-SMTP to
;;; reinitiate the command sequence by direct action at some
;;; point in the future (e.g., after the spelling has been
;;; changed, or the user has altered the account status).
;;;
;;;The second digit encodes responses in specific categories:
;;;
;;; x0z Syntax -- These replies refer to syntax errors,
;;; syntactically correct commands that don't fit any
;;; functional category, and unimplemented or superfluous
;;; commands.
;;;
;;; x1z Information -- These are replies to requests for
;;; information, such as status or help.
;;;
;;; x2z Connections -- These are replies referring to the
;;; transmission channel.
;;;
;;; x3z Unspecified as yet.
;;;
;;; x4z Unspecified as yet.
;;;
;;; x5z Mail system -- These replies indicate the status of
;;; the receiver mail system vis-a-vis the requested
;;; transfer or other mail system action.
;;; Complete list (grouped by function)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 500 Syntax error, command unrecognized
;;; [This may include errors such as command line too long]
;;; 501 Syntax error in parameters or arguments
;;; 502 Command not implemented
;;; 503 Bad sequence of commands
;;; 504 Command parameter not implemented
;;;
;;; 211 System status, or system help reply
;;; 214 Help message
;;; [Information on how to use the receiver or the meaning of a
;;; particular non-standard command; this reply is useful only
;;; to the human user]
;;;
;;; 220 <domain> Service ready
;;; 221 <domain> Service closing transmission channel
;;; 421 <domain> Service not available,
;;; closing transmission channel
;;; [This may be a reply to any command if the service knows it
;;; must shut down]
;;;
;;; 250 Requested mail action okay, completed
;;; 251 User not local; will forward to <forward-path>
;;; 450 Requested mail action not taken: mailbox unavailable
;;; [E.g., mailbox busy]
;;; 550 Requested action not taken: mailbox unavailable
;;; [E.g., mailbox not found, no access]
;;; 451 Requested action aborted: error in processing
;;; 551 User not local; please try <forward-path>
;;; 452 Requested action not taken: insufficient system storage
;;; 552 Requested mail action aborted: exceeded storage allocation
;;; 553 Requested action not taken: mailbox name not allowed
;;; [E.g., mailbox syntax incorrect]
;;; 354 Start mail input; end with <CRLF>.<CRLF>
;;; 554 Transaction failed
;;;
;;; State diagram
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONNECTION ESTABLISHMENT
;;; S: 220
;;; F: 421
;;; HELO
;;; S: 250
;;; E: 500, 501, 504, 421
;;; MAIL
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 421
;;; RCPT
;;; S: 250, 251
;;; F: 550, 551, 552, 553, 450, 451, 452
;;; E: 500, 501, 503, 421
;;; DATA
;;; I: 354 -> data -> S: 250
;;; F: 552, 554, 451, 452
;;; F: 451, 554
;;; E: 500, 501, 503, 421
;;; RSET
;;; S: 250
;;; E: 500, 501, 504, 421
;;; SEND
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 502, 421
;;; SOML
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 502, 421
;;; SAML
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 502, 421
;;; VRFY
;;; S: 250, 251
;;; F: 550, 551, 553
;;; E: 500, 501, 502, 504, 421
;;; EXPN
;;; S: 250
;;; F: 550
;;; E: 500, 501, 502, 504, 421
;;; HELP
;;; S: 211, 214
;;; E: 500, 501, 502, 504, 421
;;; NOOP
;;; S: 250
;;; E: 500, 421
;;; QUIT
;;; S: 221
;;; E: 500
;;; TURN
;;; S: 250
;;; F: 502
;;; E: 500, 503

77
scheme/lib/sunet-utilities.scm
View File

@ -1,77 +0,0 @@
; some useful utilities
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
(define (host-name-or-ip addr)
(with-fatal-error-handler
(lambda (condition more)
(call-with-values
(lambda () (socket-address->internet-address addr))
(lambda (ip port)
(format-internet-host-address ip))))
(host-info:name (host-info addr))))
(define (on-interrupt interrupt thunk)
(let lp ((event (most-recent-sigevent)))
(let ((next (next-sigevent event interrupt)))
(thunk)
(lp next))))
(define (socket-address->string socket-address . with-port?)
(let ((with-port? (:optional with-port? #t)))
(receive (host-address service-port)
(socket-address->internet-address socket-address)
(if with-port?
(format #f "~A:~A"
(format-internet-host-address host-address)
(format-port service-port))
(format #f "~A"
(format-internet-host-address host-address))))))
(define (system-fqdn)
(let ((host (host-info (system-name))))
(let loop ((addresses (host-info:addresses host)))
(if (null? addresses)
#f
(or (dns-lookup-ip (car addresses))
(loop (cdr addresses)))))))
;;; Assemble a filename from ROOT and the elts of PATH-LIST.
;;; If the assembled filename contains a .. subdirectory, return #f,
;;; otw return the filename.
(define dotdot-check
(let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir.
(lambda (root path-list)
(let ((fname (if (null? path-list) root ; Bogus hack.
(string-append (file-name-as-directory root)
(string-join path-list "/")))))
(and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir.
fname)))))
;;; Timeout on network writes?
(define (copy-inport->outport in out . maybe-buffer-size)
(let* ((buffer-size (:optional maybe-buffer-size 1024))
(buf (make-string buffer-size)))
(let loop ()
(cond ((read-string! buf in) => (lambda (nchars)
(write-string buf out 0 nchars)
(loop)))))
(force-output out)))
(define (dump fd)
(copy-inport->outport fd (current-output-port)))
(define (with-lock lock thunk)
(dynamic-wind
(lambda ()
(release-lock lock))
thunk
(lambda ()
(release-lock lock))))

198
scheme/lib/uri.scm
View File

@ -1,198 +0,0 @@
;;; -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; URI syntax -- [scheme] : path [? search ] [# fragmentid]
;;; References:
;;; - http://www.w3.org/Addressing/rfc1630.txt
;;; Original RFC
;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/URI_Overview.html
;;; General Web page of URI pointers.
(define uri-reserved (string->char-set ";/#?: ="))
(define uri-reserved-sans-= (char-set-delete uri-reserved #\=))
(define (parse-uri s)
(let* ((slen (string-length s))
;; Search forwards for colon (or intervening reserved char).
(rs1 (string-index s uri-reserved)) ; 1st reserved char
(colon (and rs1 (char=? (string-ref s rs1) #\:) rs1))
(path-start (if colon (+ colon 1) 0))
;; Search backwards for # (or intervening reserved char).
(rs-last (string-index-right s uri-reserved))
(sharp (and rs-last (char=? (string-ref s rs-last) #\#) rs-last))
;; Search backwards for ? (or intervening reserved char).
;; (NB: #\= may be after #\? and before #\#)
(rs-penult (string-index-right s
uri-reserved-sans-=
path-start
(or sharp slen)))
(ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult))
(path-end (or ques sharp slen)))
(values (and colon (substring s 0 colon))
(split-uri s path-start path-end)
(and ques (substring s (+ ques 1) (or sharp slen)))
(and sharp (substring s (+ sharp 1) slen)))))
;;; Caution:
;;; Don't use this proc until *after* you've parsed the URL -- unescaping
;;; might introduce reserved chars (like slashes and colons) that could
;;; blow your parse.
(define (unescape-uri s . maybe-start/end)
(let-optionals maybe-start/end ((start 0)
(end (string-length s)))
(let* ((esc-seq? (lambda (i) (and (< (+ i 2) end)
(char=? (string-ref s i) #\%)
(hex-digit? (string-ref s (+ i 1)))
(hex-digit? (string-ref s (+ i 2))))))
(hits (let lp ((i start) (hits 0)) ; count # of esc seqs.
(if (< i end)
(if (esc-seq? i)
(lp (+ i 3) (+ hits 1))
(lp (+ i 1) hits))
hits))))
(if (and (zero? hits) (zero? start) (= end (string-length s)))
s
(let* ((nlen (- (- end start) (* hits 2))) ; the new length
; of the
; unescaped
; string stores
; the result
(ns (make-string nlen)))
(let lp ((i start) (j 0)) ; sweep over the string
(if (< j nlen)
(lp (cond
((esc-seq? i) ; unescape
; escape-sequence
(string-set! ns j
(let ((d1 (string-ref s (+ i 1)))
(d2 (string-ref s (+ i 2))))
(ascii->char (+ (* 16 (hexchar->int d1))
(hexchar->int d2)))))
(+ i 3))
(else (string-set! ns j (string-ref s i))
(+ i 1)))
(+ j 1))))
ns)))))
(define hex-digit?
(let ((hex-digits (string->char-set "0123456789abcdefABCDEF")))
(lambda (c) (char-set-contains? hex-digits c))))
; make use of the fact that numbers and characters are in order in the ascii table
(define (hexchar->int c)
(- (char->ascii c)
(if (char-numeric? c)
(char->ascii #\0)
(- (if (char-upper-case? c)
(char->ascii #\A)
(char->ascii #\a))
10))))
(define int->hexchar
(let ((table '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
#\A #\B #\C #\D #\E #\F)))
(lambda (i) (vector-ref table i))))
;;; Caution:
;;; All reserved chars (e.g., slash, sharp, colon) get escaped: "=;/#?: "
;;; So don't apply this proc to chunks of text with syntactically meaningful
;;; reserved chars (e.g., paths with URI slashes or colons) -- they'll be
;;; escaped, and lose their special meaning. E.g. it would be a mistake
;;; to apply ESCAPE-URI to "//lcs.mit.edu:8001/foo/bar.html" because the
;;; slashes and colons would be escaped.
(define uri-escaped-chars
(char-set-complement (char-set-union char-set:letter+digit
(string->char-set "$-_@.&!*\"'(),+"))))
;;; Takes a set of chars to escape. This is because we sometimes need to
;;; escape larger sets of chars for different parts of a URI.
(define (escape-uri s . maybe-escaped-chars)
(let-optionals maybe-escaped-chars ((escaped-chars uri-escaped-chars))
(let ((nlen (string-fold
(lambda (c i)
(+ i
(if (char-set-contains? escaped-chars c)
3
1)))
0
s))) ; new length of escaped string
(if (= nlen (string-length s))
s
(let ((ns (make-string nlen)))
(string-fold
(lambda (c i) ; replace each occurance of an
; character to escape with %ff where ff
; is the ascii-code in hexadecimal
; notation
(+ i (cond
((char-set-contains? escaped-chars c)
(string-set! ns i #\%)
(let* ((d (char->ascii c))
(dhi (bitwise-and (arithmetic-shift d -4) #xF))
(dlo (bitwise-and d #xF)))
(string-set! ns (+ i 1)
(int->hexchar dhi))
(string-set! ns (+ i 2)
(int->hexchar dlo)))
3)
(else (string-set! ns i c)
1))))
0
s)
ns)))))
;;; Cribbed from scsh's fname.scm
(define (split-uri uri start end) ; Split at /'s (infix grammar).
(let split ((i start)) ; "" -> ("")
(cond
((>= i end) '(""))
((string-index uri #\/ i) =>
(lambda (slash)
(cons (substring uri i slash)
(split (+ slash 1)))))
(else (list (substring uri i end))))))
;;; The elements of PLIST must be escaped in case they contain slashes.
;;; This procedure doesn't escape them for you; you must do that yourself:
;;; (uri-path->uri (map escape-uri pathlist))
(define (uri-path->uri plist)
(string-join plist "/")) ; Insert slashes between elts of PLIST.
(define (simplify-uri-path p)
(if (null? p)
#f ; P must be non-null
(let lp ((path-list (cdr p))
(stack (list (car p))))
(if (null? path-list) ; we're done
(reverse stack)
(cond
((string=? (car path-list) "..") ; back up
; neither the empty path nor root
(if (not (or (null? stack) (string=? (car stack) "")))
(lp (cdr path-list) (cdr stack))
#f))
((string=? (car path-list) ".") ; leave this
(lp (cdr path-list) stack))
((string=? (car path-list) "") ; back to root
(lp (cdr path-list) '("")))
(else ; usual segment
(lp (cdr path-list) (cons (car path-list) stack))))))))

163
scheme/lib/url.scm
View File

@ -1,163 +0,0 @@
;;; URL parsing and unparsing -*- Scheme -*-
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;;; I'm only implementing HTTP URL's right now.
;;; References:
;;; - http://www.w3.org/Addressing/rfc1738.txt
;;; Original RFC
;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/Overview.html
;;; General Web page of URI pointers.
;;; Unresolved issues:
;;; - The server parser shouldn't substitute default values --
;;; that should happen in a separate step.
;;; The steps in hacking a URL are:
;;; - Take the UID, parse it, and resolve it with the context UID, if any.
;;; - Consult the UID's <scheme>. Pick the appropriate URL parser and parse.
;;; Server strings: //<user>:<password>@<host>:<port>/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A SERVER record describes path-prefixes of the form
;;; //<user>:<password>@<host>:<port>/
;;; These are frequently used as the initial prefix of URL's describing
;;; Internet resources.
(define-record-type server :server ; Each slot is a decoded string or #f.
(make-server user password host port)
server?
(user server-user)
(password server-password)
(host server-host)
(port server-port))
;;; Parse a URI path (a list representing a path, not a string!) into
;;; a server record. Default values are taken from the server
;;; record DEFAULT except for the host. Returns a server record if
;;; it wins. CADDR drops the server portion of the path. In fact,
;;; fatal-syntax-error is called, if the path doesn't start with '//'.
;
(define (parse-server path default)
(if (and (pair? path) ; The thing better begin
(string=? (car path) "") ; with // (i.e., have two
(pair? (cdr path)) ; initial "" elements).
(string=? (cadr path) ""))
(let* ((uhs (caddr path)) ; Server string.
(uhs-len (string-length uhs))
(at (string-index uhs #\@)) ; Usr:passwd at-sign, if any.
(colon1 (and at (string-index uhs #\:))) ; Usr:passwd colon,
(colon1 (and colon1 (< colon1 at) colon1)) ; if any.
(colon2 (string-index uhs #\: (or at 0)))) ; Host:port colon, if any.
(make-server (if at
(unescape-uri uhs 0 (or colon1 at))
(server-user default))
(if colon1
(unescape-uri uhs (+ colon1 1) at)
(server-password default))
(unescape-uri uhs (if at (+ at 1) 0)
(or colon2 uhs-len))
(if colon2
(unescape-uri uhs (+ colon2 1) uhs-len)
(server-port default))))
(fatal-syntax-error "URL must begin with //..." path)))
;;; Unparser
(define server-escaped-chars
(char-set-union uri-escaped-chars ; @ and : are also special
(string->char-set "@:"))) ; in UH strings.
(define (server->string uh)
(let* ((us (server-user uh))
(pw (server-password uh))
(ho (server-host uh))
(po (server-port uh))
;; Encode before assembly in case pieces contain colons or at-signs.
(e (lambda (s) (escape-uri s server-escaped-chars)))
(user/passwd (if us
`(,(e us) . ,(if pw `(":" ,(e pw) "@") '("@")))
'()))
(host/port (if ho
`(,(e ho) . ,(if po `(":" ,(e po)) '()))
'())))
(apply string-append (append user/passwd host/port))))
;;; HTTP URL parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The PATH slot of this record is the URL's path split at slashes,
;;; e.g., "foo/bar//baz/" => ("foo" "bar" "" "baz" "")
;;; These elements are in raw, unescaped format. To convert back to
;;; a string, use (uri-path->uri (map escape-uri pathlist)).
(define-record-type http-url :http-url
(make-http-url server path search fragment-identifier)
http-url?
(server http-url-server) ; Initial //anonymous@clark.lcs.mit.edu:80/
(path http-url-path) ; Rest of path, split at slashes & decoded.
(search http-url-search)
(fragment-identifier http-url-fragment-identifier))
;;; The URI parser (parse-uri in uri.scm) maps a string to four parts:
;;; <scheme> : <path> ? <search> # <frag-id> <scheme>, <search>, and
;;; <frag-id> are strings; <path> is a non-empty string list -- the
;;; URI's path split at slashes. Optional parts of the URI, when
;;; missing, are specified as #f. If <scheme> is "http", then the
;;; other three parts can be passed to PARSE-HTTP-URL, which parses
;;; them into a HTTP-URL record. All strings come back from the URI
;;; parser encoded. SEARCH and FRAG-ID are left that way; this parser
;;; decodes the path elements.
;;;
;;; Returns a HTTP-URL record, if possible. Otherwise
;;; FATAL-SYNTAX-ERROR is called.
(define (parse-http-url path search frag-id)
(let ((uh (parse-server path default-http-server)))
(if (or (server-user uh) (server-password uh))
(fatal-syntax-error
"HTTP URL's may not specify a user or password field" path))
(make-http-url uh (map unescape-uri (cdddr path)) search frag-id)))
(define (parse-http-url-string string)
(call-with-values
(lambda () (parse-uri string))
(lambda (scheme path search frag-id)
(if (string=? scheme "http")
(parse-http-url path search frag-id)
(fatal-syntax-error "not an HTTP URL" path)))))
;;; Default http port is 80.
(define default-http-server (make-server #f #f #f "80"))
;;; Unparse.
(define (http-url->string url)
(string-append "http://"
(server->string (http-url-server url))
"/"
(uri-path->uri (map escape-uri (http-url-path url)))
(cond ((http-url-search url) =>
(lambda (s) (string-append "?" s)))
(else ""))
(cond ((http-url-fragment-identifier url) =>
(lambda (fi) (string-append "#" fi)))
(else ""))))

791
scheme/packages.scm
View File

@ -1,791 +0,0 @@
;; Scheme 48 package definitions for the
;; Scheme Untergrund Networking Suite
;;; This file is part of the Scheme Untergrund Networking package.
;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 2000-2002 by Martin Gasbichler.
;;; Copyright (c) 1998-2001 by Eric Marsden.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
;; Interfaces
;; Net protocols and formats
(define-interface parse-html-forms-interface
(export parse-html-form-query unescape-uri+))
(define-interface htmlout-interface
(export emit-tag
emit-close-tag
emit-p
emit-title
emit-header ; And so forth...
with-tag
with-tag*
escape-html
emit-text))
(define-interface smtp-interface
(export smtp-send-mail
smtp-expand smtp-verify smtp-help
smtp-transactions
smtp-transactions/no-close
smtp-connect
smtp-helo smtp-mail smtp-rcpt smtp-data
smtp-send smtp-soml smtp-saml smtp-rset smtp-expn
smtp-help smtp-noop smtp-quit smtp-turn))
(define-interface rfc822-interface
(export read-rfc822-headers
read-rfc822-headers-with-line-breaks
read-rfc822-field
read-rfc822-field-with-line-breaks
rfc822-time->string))
(define-interface uri-interface
(export parse-uri
uri-escaped-chars
unescape-uri
escape-uri
split-uri
uri-path->uri
simplify-uri-path))
(define-interface url-interface
(export server?
make-server
server-user
server-password
server-host
server-port
parse-server
server->string
http-url?
make-http-url
http-url-server
http-url-path
http-url-search
http-url-fragment-identifier
parse-http-url
parse-http-url-string
http-url->string))
(define-interface ftp-library-interface
(export copy-port->port-binary
copy-port->port-ascii
copy-ascii-port->port
parse-port-arg))
(define-interface ftp-interface
(export ftp-connect
(ftp-type :syntax)
ftp-set-type!
ftp-rename
ftp-delete
ftp-cd
ftp-cdup
ftp-pwd
ftp-rmdir
ftp-mkdir
ftp-modification-time
ftp-size
ftp-abort
ftp-quit
ftp-ls
ftp-dir
ftp-get
ftp-put
ftp-append
ftp-quot
ftp-error?
copy-port->port-binary
copy-port->port-ascii
copy-ascii-port->port))
(define-interface netrc-interface
(export netrc-machine-entry
netrc-entry?
netrc-entry-machine
netrc-entry-login
netrc-entry-password
netrc-entry-account
netrc-macro-definitions))
(define-interface pop3-interface
(export pop3-connect
pop3-stat
pop3-retrieve-message
pop3-retrieve-headers
pop3-last
pop3-delete
pop3-reset
pop3-quit
pop3-error?))
(define-interface rfc868-interface
(export rfc868-time/tcp rfc868-time/udp))
(define-interface rfc867-interface
(export rfc867-daytime/tcp rfc867-daytime/udp))
(define-interface dns-interface
(export dns-clear-cache! ; clears the cache
dns-lookup ; complex lookup function
dns-lookup-name ; simple lookup function
dns-inverse-lookup ; obsolete, use dns-lookup-ip
dns-lookup-ip ; simple lookup function
dns-lookup-nameserver ; simple lookup function
dns-lookup-mail-exchanger ; simple lookpu function
pretty-print-dns-message ; prints a human readable dns-msg
force-ip ; reruns a lookup until a ip is resolved
force-ip-list ; reruns a lookup until a list of ips is resolved
address32->ip-string ; converts a address32 in an ip-string
ip-string->address32 ; converts a ip-string in an address32
dns-find-nameserver ; returns a nameserver
dns-find-nameserver-list ; returns a list of nameservers
socket-address->fqdn
internet-address->fqdn
host-fqdn
system-fqdn))
(define-interface cgi-scripts-interface
(export cgi-form-query))
;; Utility libraries
(define-interface rate-limit-interface
(export make-rate-limiter
rate-limit-block
rate-limit-open
rate-limit-close
rate-limiter-current-requests))
(define-interface crlf-io-interface
(export read-crlf-line
read-crlf-line-timeout
write-crlf))
(define-interface ls-interface
(export ls-crlf?
ls
arguments->ls-flags))
(define-interface format-net-interface
(export format-internet-host-address
format-port))
(define-interface sunet-utilities-interface
(export host-name-or-ip
on-interrupt
socket-address->string
dump
system-fqdn
copy-inport->outport
dotdot-check
with-lock))
(define-interface handle-fatal-error-interface
(export with-fatal-error-handler*
(with-fatal-error-handler :syntax)))
;; FTP server
(define-interface ftpd-interface
(export with-port with-anonymous-home with-banner with-logfile with-dns-lookup?
make-ftpd-options
ftpd
ftpd-inetd))
;; Web server
(define-interface httpd-core-interface
(export httpd))
(define-interface httpd-make-options-interface
(export make-httpd-options
with-port
with-root-directory
with-icon-name
with-fqdn
with-reported-port
with-request-handler
with-server-admin
with-simultaneous-requests
with-logfile
with-syslog?
with-resolve-ips?))
(define-interface httpd-read-options-interface
(export httpd-options-port
httpd-options-root-directory
httpd-options-icon-name
httpd-options-fqdn
httpd-options-reported-port
httpd-options-request-handler
httpd-options-server-admin
httpd-options-simultaneous-requests
httpd-options-logfile
httpd-options-syslog?
httpd-options-resolve-ips?))
(define-interface httpd-access-control-interface
(export access-denier
access-allower
access-controller
access-controlled-handler))
(define-interface httpd-errors-interface
(export http-error?
http-error
fatal-syntax-error?
fatal-syntax-error))
(define-interface httpd-logging-interface
(export init-http-log!
http-syslog?
http-syslog
http-log
logging
make-logging))
(define-interface httpd-requests-interface
(export make-request ; HTTP request
request? ; record type.
request-method
request-uri
request-url
request-version
request-headers
request-socket
version< version<=
v0.9-request?
version->string))
(define-interface httpd-responses-interface
(export make-response response?
response-code
response-message
response-seconds
response-mime
response-extras
response-body
make-nph-response nph-response?
nph-response-body
make-writer-body writer-body?
make-reader-writer-body reader-writer-body?
make-redirect-body redirect-body? redirect-body-location
display-http-body
status-code?
status-code-number
status-code-message
(status-code :syntax)
name->status-code
number->status-code
make-error-response
make-redirect-response))
(define-interface httpd-basic-handlers-interface
(export make-predicate-handler
make-path-predicate-handler
make-host-name-handler
make-path-prefix-handler
alist-path-dispatcher
null-request-handler))
(define-interface httpd-file-directory-handlers-interface
(export home-dir-handler
tilde-home-dir-handler
rooted-file-handler
rooted-file-or-directory-handler))
(define-interface httpd-seval-handlers-interface
(export seval-handler))
(define-interface httpd-info-gateway-interface
(export info-handler
find-info-file
info-gateway-error))
(define-interface httpd-rman-gateway-interface
(export rman-handler
man
parse-man-entry
cat-man-page
find-man-file
file->man-directory
cat-n-decode
nroff-n-decode))
(define-interface httpd-cgi-handlers-interface
(export cgi-default-bin-path
cgi-handler))
(define-interface loser-interface (export loser))
(define-interface toothless-interface (interface-of scheme))
(define-interface toothless-eval-interface (export eval-safely))
;; Structures
(define-structure sunet-version (export sunet-version-identifier)
(open scheme)
(begin
(define sunet-version-identifier "2.0")))
;; Net protocols and formats
(define-structure parse-html-forms parse-html-forms-interface
(open scheme-with-scsh
let-opt
(subset srfi-13 (string-index string-map))
receiving
uri)
(files (lib parse-forms)))
(define-structure htmlout htmlout-interface
(open scheme-with-scsh
(subset srfi-13 (string-fold))
formats
ascii
receiving)
(files (lib htmlout)))
(define-structure smtp smtp-interface
(open scheme-with-scsh
signals conditions
define-record-types
(subset srfi-1 (filter-map))
(subset srfi-13 (string-tokenize string-join))
crlf-io ; read-crlf-line write-crlf
receiving ; values receive
dns ; SYSTEM-FQDN
let-opt
(subset rfc822 (rfc822-time->string)))
(files (lib smtp)))
(define-structure rfc822 rfc822-interface
(open scheme-with-scsh
receiving
(subset srfi-13 (string-map string-index string-concatenate))
let-opt
crlf-io
ascii)
(files (lib rfc822)))
(define-structure uri uri-interface
(open scheme-with-scsh
(subset srfi-13 (string-index string-index-right string-fold string-join))
let-opt
receiving
ascii
bitwise
field-reader-package)
(files (lib uri)))
(define-structure url url-interface
(open scheme-with-scsh
define-record-types
receiving
(subset srfi-13 (string-index))
uri
httpd-errors)
(files (lib url)))
(define-structure ftp-library ftp-library-interface
(open scheme-with-scsh
(subset signals (call-error))
(subset srfi-1 (any))
crlf-io)
(files (lib ftp-library)))
(define-structure ftp ftp-interface
(open scheme-with-scsh
netrc
define-record-types
finite-types
receiving
handle
conditions
signals
(subset srfi-13 (string-join string-prefix?))
let-opt
sunet-utilities
format-net
crlf-io
ftp-library)
(files (lib ftp)))
(define-structure netrc netrc-interface
(open scheme-with-scsh
define-record-types
srfi-14)
(files (lib netrc)))
(define-structure pop3 pop3-interface
(open scheme-with-scsh
netrc rfc822
define-record-types
handle
conditions handle-fatal-error
signals
(subset srfi-13 (string-index string-prefix? string-join))
let-opt
crlf-io)
(files (lib pop3)))
(define-structures ((rfc867 rfc867-interface)
(rfc868 rfc868-interface))
(open scheme-with-scsh
handle-fatal-error)
(files (lib nettime)))
(define-structure dns dns-interface
(open scheme-with-scsh
(subset srfi-1 (filter reverse! delete lset-difference lset-union))
tables
ascii
formats
signals
finite-types
define-record-types
random
queues
conditions
handle
sort
threads
locks)
(files (lib dns)))
(define-structure cgi-scripts cgi-scripts-interface
(open scheme-with-scsh
parse-html-forms)
(files (lib cgi-script)))
;; Utility libraries
(define-structure rate-limit rate-limit-interface
(open scheme
define-record-types
locks
signals)
(files (lib rate-limit)))
(define-structure crlf-io crlf-io-interface
(open scheme-with-scsh
ascii ; ascii->char
receiving ; MV return (RECEIVE and VALUES)
let-opt ; let-optionals
threads ; sleep
)
(files (lib crlf-io)))
(define-structure ls ls-interface
(open scheme-with-scsh
handle
(subset srfi-1 (filter))
bitwise
fluids
crlf-io)
(files (lib ls)))
(define-structure format-net format-net-interface
(open scheme-with-scsh
let-opt)
(files (lib format-net)))
(define-structure sunet-utilities sunet-utilities-interface
(open scheme-with-scsh
format-net
sigevents
let-opt
(subset srfi-13 (string-join))
dns
let-opt ; :optional
locks
handle-fatal-error)
(files (lib sunet-utilities)))
(define-structure handle-fatal-error handle-fatal-error-interface
(open scheme conditions handle)
(files (lib handle-fatal-error)))
;; FTP server
(define-structure ftpd ftpd-interface
(open scheme-with-scsh
conditions handle signals
define-record-types
handle-fatal-error
threads threads-internal ; last one to get CURRENT-THREAD
fluids thread-fluids
locks
(subset srfi-13 (string-map string-trim-both string-index))
(subset srfi-1 (partition))
crlf-io
ls
ftp-library
dns
sunet-version
sunet-utilities
receiving
format-net)
(files (ftpd ftpd)))
;; Web server
(define-structure httpd-core httpd-core-interface
(open scheme-with-scsh
thread-fluids ; fork-thread
receiving
crlf-io ; write-crlf, read-crlf-line
rfc822
handle ; ignore-errors
conditions ; condition-stuff
uri
url
format-net
rate-limit ; rate-limiting stuff
(subset srfi-13 (string-index))
dns ; dns-lookup-ip
sunet-utilities ; socket-address->string
locks ; make-lock et al.
fluids ; let-fluid
enumerated ; enum
architecture ; os-error
handle-fatal-error
httpd-read-options
httpd-errors
httpd-logging
httpd-requests
httpd-responses
sunet-version
)
(files (httpd core)))
(define-structures ((httpd-make-options httpd-make-options-interface)
(httpd-read-options httpd-read-options-interface))
(open scheme
define-record-types)
(files (httpd options)))
(define-structure httpd (compound-interface httpd-core-interface
httpd-make-options-interface)
(open httpd-core
httpd-make-options))
(define-structure httpd-access-control httpd-access-control-interface
(open scheme-with-scsh
(subset srfi-1 (any every))
httpd-responses
httpd-requests
httpd-errors
(subset srfi-13 (string-map))
)
(files (httpd access-control)))
(define-structure httpd-errors httpd-errors-interface
(open conditions signals handle scheme)
(files (httpd error)))
(define-structure httpd-logging httpd-logging-interface
(open scheme-with-scsh
httpd-read-options
i/o ; make-null-output-port
locks
receiving
uri ; uri-path->uri
url ; http-url-path
httpd-requests ; request record
httpd-responses
formats
format-net ; format-internet-host-address
(subset srfi-13 (string-join string-trim))
rfc822 ; get-header
sunet-utilities ; on-interrupt
threads ; spawn
dns ; dns-lookup-ip
define-record-types
thread-fluids ; make-preserved-fluid et al.
handle-fatal-error
)
(files (httpd logging)))
(define-structure httpd-requests httpd-requests-interface
(open scheme
define-record-types)
(files (httpd request)))
(define-structure httpd-responses httpd-responses-interface
(open scheme
(subset scsh (format-date write-string time date))
syslog
define-record-types
finite-types
formats
(subset signals (call-error))
httpd-requests
httpd-read-options)
(files (httpd response)))
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
(open scheme-with-scsh
rfc822
httpd-requests ; REQUEST record type, v0.9-request
(subset srfi-1 (fold-right))
(subset srfi-13 (string-trim))
httpd-responses
httpd-errors
)
(files (httpd handlers)))
(define-structure httpd-file-directory-handlers httpd-file-directory-handlers-interface
(open scheme-with-scsh
httpd-core
httpd-requests
httpd-responses
httpd-errors
httpd-basic-handlers
httpd-read-options
url
htmlout
crlf-io
(subset srfi-13 (string-join))
sunet-utilities ; dotdot-check, copy-inport->outport
conditions
handle-fatal-error
)
(files (httpd file-dir-handler)))
(define-structure httpd-seval-handlers httpd-seval-handlers-interface
(open scheme-with-scsh ; syscalls & INDEX
httpd-errors
httpd-requests ; v0.9-request
httpd-responses
httpd-logging ; http-log
uri ; UNESCAPE-URI
htmlout ; Formatted HTML output
pp
(subset srfi-13 (string-skip))
rfc822
toothless-eval ; EVAL-SAFELY
handle ; IGNORE-ERROR
parse-html-forms ; PARSE-HTML-FORM-QUERY
threads ; SLEEP
)
(files (httpd seval)))
(define-structure httpd-info-gateway httpd-info-gateway-interface
(open scheme-with-scsh
(subset srfi-1 (find))
(subset srfi-13 (string-map string-skip string-index))
conditions signals handle
htmlout
httpd-requests
httpd-responses
httpd-errors
url
uri
handle-fatal-error)
(files (httpd info-gateway)))
(define-structure httpd-rman-gateway httpd-rman-gateway-interface
(open scheme-with-scsh
httpd-responses
httpd-requests
httpd-errors
conditions
url
uri
htmlout
httpd-basic-handlers
handle-fatal-error
let-opt
sunet-utilities
(subset srfi-13 (string-join))
)
(files (httpd rman-gateway)))
(define-structure httpd-cgi-handlers httpd-cgi-handlers-interface
(open scheme-with-scsh
(subset srfi-1 (alist-delete))
(subset srfi-13 (string-prefix? string-index string-trim substring/shared))
rfc822
crlf-io ; WRITE-CRLF
uri
url ; HTTP-URL record type
httpd-logging
httpd-requests
httpd-responses
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
httpd-errors ; HTTP-ERROR
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
sunet-version
formats
format-net
sunet-utilities ; host-name-or-empty
let-opt ; let-optionals
handle-fatal-error
)
(files (httpd cgi-server)))
(define-structure loser (export loser)
(open scheme signals)
(begin (define (loser name)
(lambda x (error "Illegal call" name)))))
(define-structure toothless toothless-interface
(open scheme loser)
(begin
(define call-with-input-file (loser "call-with-input-file"))
(define call-with-output-file (loser "call-with-output-file"))
(define load (loser "load"))
(define open-input-file (loser "open-input-file"))
(define open-output-file (loser "open-output-file"))
(define transcript-on (loser "transcript-on"))
(define with-input-from-file (loser "with-input-from-file"))
(define with-input-to-file (loser "with-input-to-file"))
(define eval (loser "eval"))
(define interaction-environment (loser "interaction-environment"))
(define scheme-report-environment (loser "scheme-report-environment"))))
(define-structure toothless-eval toothless-eval-interface
(open scheme
package-commands-internal ; config-package, get-reflective-tower
packages ; structure-package, make-simple-package
environments ; environment-ref
handle ; ignore-errors
)
(access toothless) ; Force it to be loaded.
(begin
(define toothless-struct (environment-ref (config-package) 'toothless))
(define toothless-package (structure-package toothless-struct))
(define (new-safe-package)
(make-simple-package (list toothless-struct) #t
(get-reflective-tower toothless-package) ; ???
'safe-env))
(define (eval-safely exp)
(ignore-errors (lambda () (eval exp (new-safe-package)))))))

283
scheme/xml/doc.txt
View File

@ -1,283 +0,0 @@
_XML_ Library
=============
Files: xml.ss xmlr.ss xmls.ss
Signature: xml^
Basic XML Data Types
====================
Document:
This structure represents an XML document. The only useful part is
the document-element, which contains all the content. The rest of
of the structure contains DTD information, which isn't supported,
and processing-instructions.
Element:
Each pair of start/end tags and everything in between is an element.
It has the following pieces:
a name
attributes
contents including sub-elements
Xexpr:
S-expression representations of XML data.
The end of this document has more details.
Functions
=========
> read-xml : [Input-port] -> Document
reads in an XML document from the given or current input port
XML documents contain exactly one element. It throws an xml-read:error
if there isn't any element or if there are more than one element.
Malformed xml is reported with source locations in
the form `l.c/o', where l is the line number, c is
the column number and o is the number of characters
from the beginning of the file.
> write-xml : Document [Output-port] -> Void
writes a document to the given or current output port, currently
ignoring everything except the document's root element.
> write-xml/content : Content [Output-port] -> Void
writes a document's contents to the given or current output port
> display-xml : Document [Output-port] -> Void
just like write-xml, but newlines and indentation make the output more
readable, though less technically correct when white space is
significant.
> display-xml/content : Content [Output-port] -> Void
just like write-xml/content, but with indentation and newlines
> xml->xexpr : Content -> Xexpr
converts the interesting part of an XML document into an Xexpression
> xexpr->xml : Xexpr -> Content
converts an Xexpression into the interesting part of an XML document
> xexpr->string : Xexpression -> String
converts an Xexpression into a string representation
> eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
Some elements should not contain any text, only other tags, except they
often contain whitespace for formating purposes. Given a list of tag names
and the identity function, eliminate-whitespace produces a function that
filters out pcdata consisting solely of whitespace from those elements and
raises and error if any non-whitespace text appears. Passing in the function
called "not" instead of the identity function filters all elements which are not
named in the list. Using void filters all elements regardless of the list.
Parameters
==========
> empty-tag-shorthand : 'always | 'never | (listof Symbol)
Default: 'always
This determines if the output functions should use the <empty/> tag
notation instead of writing <empty></empty>. The first form is the
preferred XML notation. However, most browsers designed for HTML
will only properly render XHTML if the document uses a mixture of the
two formats. _html-empty-tags_ contains the W3 consortium's
recommended list of XHTML tags that should use the shorthand.
> collapse-whitespace : Bool
Default: #f
All consecutive whitespace is replaced by a single space.
CDATA sections are not affected.
> trim-whitespace : Bool
This parameter no longer exists. Consider using collapse-whitespace
and eliminate-whitespace instead.
> read-comments : Bool
Default: #f
Comments, by definition, should be ignored by programs. However,
interoperating with ad hoc extentions to other languages sometimes
requires processing comments anyway.
> xexpr-drop-empty-attributes : Bool
Default: #f
It's easier to write functions processing Xexpressions, if they always
have a list of attributes. On the other hand, it's less cumbersome to
write Xexpresssions by hand without empty lists of attributes
everywhere. Normally xml->xexpr leaves in empty attribute lists.
Setting this parameter to #t drops them, so further editing the
Xexpression by hand is less annoying.
Examples
========
Reading an Xexpression:
(xml->xexpr (document-element (read-xml input-port)))
Writing an Xexpression:
(empty-tag-shorthand html-empty-tags)
(write-xml/content (xexpr->xml `(html (head (title ,banner))
(body ((bgcolor "white"))
,text)))
output-port)
What this Library Doesn't Provide
=================================
Document Type Declaration (DTD) processing
Validation
Expanding user-defined entites
Reading user-defined entites in attributes
Unicode support
XML Datatype Details
====================
Note: Users of the XML collection don't need to know most of these definitions.
Note: Xexpr is the only important one to understand. Even then,
Processing-instructions may be ignored.
> Xexpr = String
| (list* Symbol (listof (list Symbol String)) (list Xexpr))
| (cons Symbol (listof Xexpr)) ;; an element with no attributes
| Symbol ;; symbolic entities such as &nbsp;
| Number ;; numeric entities like &#20;
| Misc
> Document = (make-document Prolog Element (listof Processing-instruction))
(define-struct document (prolog element misc))
> Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
(define-struct prolog (misc dtd misc2))
The last field is a (listof Misc), but the maker accepts optional
arguments instead for backwards compatibility.
> Document-type = #f | (make-document-type Symbol External-dtd #f)
(define-struct document-type (name external inlined))
> External-dtd = (make-external-dtd/public str str)
| (make-external-dtd/system str)
| #f
(define-struct external-dtd (system))
(define-struct (external-dtd/public external-dtd) (public))
(define-struct (external-dtd/system external-dtd) ())
> Element = (make-element Location Location
Symbol
(listof Attribute)
(listof Content))
(define-struct (element struct:source) (name attributes content))
> Attribute = (make-attribute Location Location Symbol String)
(define-struct (attribute struct:source) (name value))
> Content = Pcdata
| Element
| Entity
| Misc
Misc = Comment
| Processing-instruction
> Pcdata = (make-pcdata Location Location String)
(define-struct (pcdata struct:source) (string))
> Entity = (make-entity (U Nat Symbol))
(define-struct entity (text))
> Processing-instruction = (make-pi Location Location String (list String))
(define-struct (pi struct:source) (target-name instruction))
> Comment = (make-comment String)
(define-struct comment (text))
Source = (make-source Location Location)
(define-struct source (start stop))
Location = Nat
| Symbol
The PList Library
=================
Files: plist.ss
The PList library provides the ability to read and write xml documents which
conform to the "plist" DTD, used to store 'dictionaries' of string - value
associations.
To Load
=======
(require (lib "plist.ss" "xml"))
Functions
=========
> read-plist : Port -> PLDict
reads a plist from a port, and produces a 'dict' x-expression
> write-plist : PLDict Port -> Void
writes a plist to the given port. May raise the exn:application:type
exception if the plist is badly formed.
Datatypes
=========
NB: all of these are subtypes of x-expression:
> PLDict = (list 'dict Assoc-pair ...)
> PLAssoc-pair = (list 'assoc-pair String PLValue)
> PLValue = String
| (list 'true)
| (list 'false)
| (list 'integer Integer)
| (list 'real Real)
| PLDict
| PLArray
> PLArray = (list 'array PLValue ...)
In fact, the PList DTD also defines Data and Date types, but we're ignoring
these for the moment.
Examples
========
Here's a sample PLDict:
(define my-dict
`(dict (assoc-pair "first-key"
"just a string
with some whitespace in it")
(assoc-pair "second-key"
(false))
(assoc-pair "third-key"
(dict ))
(assoc-pair "fourth-key"
(dict (assoc-pair "inner-key"
(real 3.432))))
(assoc-pair "fifth-key"
(array (integer 14)
"another string"
(true)))
(assoc-pair "sixth-key"
(array))))
Let's write it to disk:
(call-with-output-file "/Users/clements/tmp.plist"
(lambda (port)
(write-plist my-dict port))
'truncate)
Let's read it back from the disk:
(define new-dict
(call-with-input-file "/Users/clements/tmp.plist"
(lambda (port)
(read-plist port))))

153
scheme/xml/plt.scm
View File

@ -1,153 +0,0 @@
; Taken directly from the SRFI document.
(define-syntax let-values
(syntax-rules ()
((let-values (?binding ...) ?body0 ?body1 ...)
(let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
((let-values "bind" () ?tmps ?body)
(let ?tmps ?body))
((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
(let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
(call-with-values
(lambda () ?e0)
(lambda ?args
(let-values "bind" ?bindings ?tmps ?body))))
((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
(let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
(call-with-values
(lambda () ?e0)
(lambda (?arg ... . x)
(let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
(define-syntax let*-values
(syntax-rules ()
((let*-values () ?body0 ?body1 ...)
(begin ?body0 ?body1 ...))
((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
(let-values (?binding0)
(let*-values (?binding1 ...) ?body0 ?body1 ...)))))
(define (add1 x) (+ x 1))
(define (sub1 x) (- x 1))
(define-syntax when
(syntax-rules
()
((when test expr ...)
(if test (begin expr ...)))))
(define-syntax unless
(syntax-rules
()
((unless test expr ...)
(if (not test) (begin expr ...)))))
(define (void . a)
(if #f #f))
(define-syntax begin0
(syntax-rules
()
((begin0 expr1 expr ...)
(let ((r expr1))
(begin expr ...)
r))))
(define andmap
(lambda (f list0 . lists)
(if (null? list0)
(and)
(let loop ((lists (cons list0 lists)))
(if (null? (cdr (car lists)))
(apply f (map car lists))
(and (apply f (map car lists))
(loop (map cdr lists))))))))
(define null '())
; stolen from mzlib/functior.ss
(define (quicksort l less-than)
(let* ((v (list->vector l))
(count (vector-length v)))
(let loop ((min 0)(max count))
(if (< min (sub1 max))
(let ((pval (vector-ref v min)))
(let pivot-loop ((pivot min)
(pos (add1 min)))
(if (< pos max)
(let ((cval (vector-ref v pos)))
(if (less-than cval pval)
(begin
(vector-set! v pos (vector-ref v pivot))
(vector-set! v pivot cval)
(pivot-loop (add1 pivot) (add1 pos)))
(pivot-loop pivot (add1 pos))))
(if (= min pivot)
(loop (add1 pivot) max)
(begin
(loop min pivot)
(loop pivot max))))))))
(vector->list v)))
;;; HACK!
(define call/ec call-with-current-continuation)
(define-syntax let/ec
(syntax-rules
()
((let/ec k expr ...)
(call-with-current-continuation (lambda (k) expr ...)))))
;;; HACK!
(define (make-parameter val . maybe-guard)
(if (null? maybe-guard)
(lambda ()
val)
(lambda ()
((car maybe-guard) val))))
(define (list* . args)
(if (null? (cdr args))
(car args)
(cons (car args) (apply list* (cdr args)))))
(define (format str . args)
(apply (structure-ref big-scheme format) #f str args))
(define fprintf (structure-ref big-scheme format))
(define foldr (structure-ref list-lib fold-right))
(define regexp posix-string->regexp)
;;; convert "\\1y \\2" to '(1 "y " 2)
(define (convert-string str)
(let ((e.s
(regexp-fold (rx (: "\\" numeric))
(lambda (s m nil)
(cons (match:end m)
(append (cdr nil)
(list (substring str (car nil) (match:start m))
(string->number
(string-drop (match:substring m) 2))))))
(cons 0 '()) str)))
(append (cdr e.s) (list (substring str (car e.s) (string-length str))))))
;;; does not handle &
(define (regexp-replace* pattern string insert-string)
(apply regexp-substitute/global #f pattern string
(append (cons 'pre (convert-string insert-string)) (list 'post))))
(define (compose f g)
(lambda (x)
(call-with-values (lambda () (g x)) f)))
(define open-output-string make-string-output-port)
(define get-output-string string-output-port-output)

378
scheme/xml/reader.scm
View File

@ -1,378 +0,0 @@
;; Token ::= Contents | Start-tag | End-tag | Eof
(define read-comments (make-parameter #f))
(define collapse-whitespace (make-parameter #f))
;; read-xml : [Input-port] -> Document
(define (read-xml . maybe-port)
(read-from-port (if (null? maybe-port) (current-input-port) (car maybe-port))))
;; read-from-port : Input-port -> Document
(define (read-from-port in)
(let*-values (((in pos) (positionify in))
((misc0 start) (read-misc in pos)))
(make-document (make-prolog misc0 #f)
(cond
((start-tag? start) (read-element start in pos))
((element? start) start)
(else (error 'read-xml "expected root element - received ~a" start)))
(let-values (((misc1 end-of-file) (read-misc in pos)))
(unless (eof-object? end-of-file)
(error 'read-xml "extra stuff at end of document ~a" end-of-file))
misc1))))
;; read-misc : Input-port (-> Location) -> (listof Misc) Token
(define (read-misc in pos)
(let read-more ()
(let ((x (lex in pos)))
(cond
((or (pi? x) (comment? x))
(let-values (((lst next) (read-more)))
(values (cons x lst) next)))
((and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x))))
(read-more))
(else (values null x))))))
;; read-element : Start-tag Input-port (-> Location) -> Element
(define (read-element start in pos)
(let ((name (start-tag-name start))
(a (source-start start))
(b (source-stop start)))
(make-element
a b name (start-tag-attrs start)
(let read-content ()
(let ((x (lex in pos)))
(cond
((eof-object? x)
(error 'read-xml "unclosed ~a tag at [~a ~a]" name
(format-source a)
(format-source b)))
((start-tag? x) (cons (read-element x in pos) (read-content)))
((end-tag? x)
(unless (eq? name (end-tag-name x))
(error 'read-xml "start tag ~a at [~a ~a] doesn't match end tag ~a at [~a ~a]"
name
(format-source a)
(format-source b)
(end-tag-name x)
(format-source (source-start x))
(format-source (source-stop x))))
null)
((entity? x) (cons (expand-entity x) (read-content)))
((comment? x) (if (read-comments)
(cons x (read-content))
(read-content)))
(else (cons x (read-content)))))))))
;; expand-entity : Entity -> (U Entity Pcdata)
;; more here - allow expansion of user defined entities
(define (expand-entity x)
(let ((expanded (default-entity-table (entity-text x))))
(if expanded
(make-pcdata (source-start x) (source-stop x) expanded)
x)))
;; default-entity-table : Symbol -> (U #f String)
(define (default-entity-table name)
(case name
((amp) "&")
((lt) "<")
((gt) ">")
((quot) "\"")
((apos) "'")
(else #f)))
;; lex : Input-port (-> Location) -> Token
(define (lex in pos)
(let ((c (peek-char in)))
(cond
((eof-object? c) c)
((eq? c #\&) (lex-entity in pos))
((eq? c #\<) (lex-tag-cdata-pi-comment in pos))
(else (lex-pcdata in pos)))))
;; lex-entity : Input-port (-> Location) -> Entity
(define (lex-entity in pos)
(let ((start (pos)))
(read-char in)
(let ((data (case (peek-char in)
((#\#)
(read-char in)
(let ((n (case (peek-char in)
((#\x) (read-char in)
(string->number (read-until #\; in pos) 16))
(else (string->number (read-until #\; in pos))))))
(unless (number? n)
(lex-error in pos "malformed numeric entity"))
n))
(else
(begin0
(lex-name in pos)
(unless (eq? (read-char in) #\;)
(lex-error in pos "expected ; at the end of an entity")))))))
(make-entity start (pos) data))))
;; lex-tag-cdata-pi-comment : Input-port (-> Location) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment
(define (lex-tag-cdata-pi-comment in pos)
(let ((start (pos)))
(read-char in)
(case (non-eof peek-char in pos)
((#\!)
(read-char in)
(case (non-eof peek-char in pos)
((#\-) (read-char in)
(unless (eq? (read-char in) #\-)
(lex-error in pos "expected second - after <!-"))
(let ((data (lex-comment-contents in pos)))
(unless (eq? (read-char in) #\>)
(lex-error in pos "expected > to end comment (\"--\" can't appear in comments)"))
;(make-comment start (pos) data)
(make-comment data)))
((#\[) (read-char in)
(unless (string=? (read-string 6 in) "CDATA[")
(lex-error in pos "expected CDATA following <["))
(let ((data (lex-cdata-contents in pos)))
(make-pcdata start (pos) data)))
(else (skip-dtd in pos)
(skip-space in)
(unless (eq? (peek-char in) #\<)
(lex-error in pos "expected pi, comment, or element after doctype"))
(lex-tag-cdata-pi-comment in pos))))
((#\?) (read-char in)
(let ((name (lex-name in pos)))
(skip-space in)
(let ((data (lex-pi-data in pos)))
(make-pi start (pos) name data))))
((#\/) (read-char in)
(let ((name (lex-name in pos)))
(skip-space in)
(unless (eq? (read-char in) #\>)
(lex-error in pos "expected > to close ~a's end tag" name))
(make-end-tag start (pos) name)))
(else
(let ((name (lex-name in pos))
(attrs (lex-attributes in pos)))
(skip-space in)
(case (read-char in)
((#\/)
(unless (eq? (read-char in) #\>)
(lex-error in pos "expected > to close empty element ~a" name))
(make-element start (pos) name attrs null))
((#\>) (make-start-tag start (pos) name attrs))
(else (lex-error in pos "expected / or > to close tag `~a'" name))))))))
;; lex-attributes : Input-port (-> Location) -> (listof Attribute)
(define (lex-attributes in pos)
(quicksort (let loop ()
(skip-space in)
(cond
((name-start? (peek-char in))
(cons (lex-attribute in pos) (loop)))
(else null)))
(lambda (a b)
(let ((na (attribute-name a))
(nb (attribute-name b)))
(cond
((eq? na nb) (lex-error in pos "duplicated attribute name ~a" na))
(else (string<? (symbol->string na) (symbol->string nb))))))))
;; lex-attribute : Input-port (-> Location) -> Attribute
(define (lex-attribute in pos)
(let ((start (pos))
(name (lex-name in pos)))
(skip-space in)
(unless (eq? (read-char in) #\=)
(lex-error in pos "expected = in attribute ~a" name))
(skip-space in)
;; more here - handle entites and disallow "<"
(let* ((delimiter (read-char in))
(value (case delimiter
((#\' #\")
(list->string
(let read-more ()
(let ((c (non-eof peek-char in pos)))
(cond
((eq? c delimiter) (read-char in) null)
((eq? c #\&)
(let ((entity (expand-entity (lex-entity in pos))))
(if (pcdata? entity)
(append (string->list (pcdata-string entity)) (read-more))
;; more here - do something with user defined entites
(read-more))))
(else (read-char in) (cons c (read-more))))))))
(else (lex-error in pos "attribute values must be in ''s or in \"\"s")))))
(make-attribute start (pos) name value))))
;; skip-space : Input-port -> Void
;; deviation - should sometimes insist on at least one space
(define (skip-space in)
(let loop ()
(let ((c (peek-char in)))
(when (and (not (eof-object? c)) (char-whitespace? c))
(read-char in)
(loop)))))
;; lex-pcdata : Input-port (-> Location) -> Pcdata
;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec
(define (lex-pcdata in pos)
(let ((start (pos))
(data (let loop ()
(let ((next (peek-char in)))
(cond
((or (eof-object? next) (eq? next #\&) (eq? next #\<))
null)
((and (char-whitespace? next) (collapse-whitespace))
(skip-space in)
(cons #\space (loop)))
(else (cons (read-char in) (loop))))))))
(make-pcdata start
(pos)
(list->string data))))
;; lex-name : Input-port (-> Location) -> Symbol
(define (lex-name in pos)
(let ((c (read-char in)))
(unless (name-start? c)
(lex-error in pos "expected name, received ~a" c))
(string->symbol
(list->string
(cons c (let lex-rest ()
(cond
((name-char? (peek-char in))
(cons (read-char in) (lex-rest)))
(else null))))))))
;; skip-dtd : Input-port (-> Location) -> Void
(define (skip-dtd in pos)
(let skip ()
(case (non-eof read-char in pos)
((#\') (read-until #\' in pos) (skip))
((#\") (read-until #\" in pos) (skip))
((#\<)
(case (non-eof read-char in pos)
((#\!) (case (non-eof read-char in pos)
((#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip))
(else (skip) (skip))))
((#\?) (lex-pi-data in pos) (skip))
(else (skip) (skip))))
((#\>) (void))
(else (skip)))))
;; name-start? : Char -> Bool
(define (name-start? ch)
(or (char-alphabetic? ch)
(eq? ch #\_)
(eq? ch #\:)))
;; name-char? : Char -> Bool
(define (name-char? ch)
(or (name-start? ch)
(char-numeric? ch)
(eq? ch #\.)
(eq? ch #\-)))
;; read-until : Char Input-port (-> Location) -> String
;; discards the stop character, too
(define (read-until char in pos)
(list->string
(let read-more ()
(let ((c (non-eof read-char in pos)))
(cond
((eq? c char) null)
(else (cons c (read-more))))))))
;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Location) -> Char
(define (non-eof f in pos)
(let ((c (f in)))
(cond
((eof-object? c) (lex-error in pos "unexpected eof"))
(else c))))
;; gen-read-until-string : String -> Input-port (-> Location) -> String
;; uses Knuth-Morris-Pratt from
;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876
;; discards stop from input
(define (gen-read-until-string stop)
(let* ((len (string-length stop))
(prefix (make-vector len 0))
(fall-back
(lambda (k c)
(let ((k (let loop ((k k))
(cond
((and (> k 0) (not (eq? (string-ref stop k) c)))
(loop (vector-ref prefix (sub1 k))))
(else k)))))
(if (eq? (string-ref stop k) c)
(add1 k)
k)))))
(let init ((k 0) (q 1))
(when (< q len)
(let ((k (fall-back k (string-ref stop q))))
(vector-set! prefix q k)
(init k (add1 q)))))
;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop
(lambda (in pos)
(list->string
(let/ec out
(let loop ((matched 0) (out out))
(let* ((c (non-eof read-char in pos))
(matched (fall-back matched c)))
(cond
((= matched len) (out null))
((zero? matched) (cons c (let/ec out (loop matched out))))
(else (cons c (loop matched out)))))))))))
;; "-->" makes more sense, but "--" follows the spec.
(define lex-comment-contents (gen-read-until-string "--"))
(define lex-pi-data (gen-read-until-string "?>"))
(define lex-cdata-contents (gen-read-until-string "]]>"))
;; positionify : Input-port -> Input-port (-> Location)
;; Well, this really depends on scsh-0.6 and should be replace by
;; big-scheme's more-port
;; For S48 you probably need to do something completely different
(define (positionify in)
(let ((line 1)
(char 0)
(offset 0)
(old-handler (port-handler in)))
(set-port-buffering in bufpol/block 1)
(let ((handler (make-buffered-input-port-handler
(port-handler-discloser old-handler)
(port-handler-close old-handler)
(lambda (data buffer start needed)
(let ((res
((port-handler-buffer-proc old-handler)
data buffer start needed)))
(if (number? res)
(begin
(set! char (add1 char))
(set! offset (add1 offset))
(let ((c (byte-vector-ref buffer 0)))
(when (= c 10)
(set! line (+ line 1))
(set! char -1)))))
res))
(port-handler-ready? old-handler)
(port-handler-steal old-handler))))
(set-port-handler! in handler)
(values in
(lambda ()
(make-location line char offset))))))
; (- n (- (port-limit in) (port-index in))))))))
;; lex-error : Input-port String (-> Location) TST* -> alpha
(define (lex-error in pos str . rest)
(error 'lex-error " at position:" (format-source (pos)) str rest))
;; format-source : Location -> string
;; to format the source location for an error message
(define (format-source loc)
(if (location? loc)
(format #f "~a.~a/~a" (location-line loc) (location-char loc) (location-offset loc))
(format #f "~a" loc)))

26
scheme/xml/space.scm
View File

@ -1,26 +0,0 @@
;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element
(define (eliminate-whitespace special eliminate-special?)
(letrec ((blank-it
(lambda (el)
(let ((name (element-name el))
(content (map (lambda (x)
(if (element? x) (blank-it x) x))
(element-content el))))
(make-element
(source-start el)
(source-stop el)
name
(element-attributes el)
(cond
((eliminate-special? (memq (element-name el) special))
(filter (lambda (s)
(not (and (pcdata? s)
(or (all-blank (pcdata-string s))
(error 'eliminate-blanks "Element <~a> is not allowed to contain text ~s" name (pcdata-string s))))))
content))
(else content)))))))
blank-it))
;; all-blank : String -> Bool
(define (all-blank s)
(andmap char-whitespace? (string->list s)))

194
scheme/xml/structures.scm
View File

@ -1,194 +0,0 @@
; Location = (make-location Nat Nat) | Symbol
(define-record-type location :location
(make-location line char offset)
location?
(line location-line)
(char location-char)
(offset location-offset))
;; Source ::= (make-source Location Location)
(define-record-type source :source
(make-source start stop)
really-source?
(start really-source-start)
(stop really-source-stop))
(define (source-start obj)
(cond ((element? obj) (element-start obj))
((attribute? obj) (attribute-start obj))
((pcdata? obj) (pcdata-start obj))
((entity? obj) (entity-start obj))
((pi? obj) (pi-start obj))
((start-tag? obj) (start-tag-start obj))
((end-tag? obj) (end-tag-start obj))
(else (really-source-start obj))))
(define (source-stop obj)
(cond ((element? obj) (element-stop obj))
((attribute? obj) (attribute-stop obj))
((pcdata? obj) (pcdata-stop obj))
((entity? obj) (entity-stop obj))
((pi? obj) (pi-stop obj))
((start-tag? obj) (start-tag-stop obj))
((end-tag? obj) (end-tag-stop obj))
(else (really-source-stop obj))))
(define (does-any-satisfy? preds obj)
(if (null? preds)
#f
(or ((car preds) obj) (does-any-satisfy? (cdr preds) obj))))
(define (source? obj)
(does-any-satisfy? (list really-source? element? attribute? pcdata?
entity? pi? start-tag? end-tag?)
obj))
;; Document ::= (make-document Prolog Element (listof Misc))
(define-record-type document :document
(make-document prolog element misc)
document?
(prolog document-prolog)
(element document-element)
(misc document-misc))
; Prolog = (make-prolog (listof Misc) Document-type [Misc ...])
; The Misc items after the Document-type are optional arguments to maintain
; backward compatability with older versions of the XML library.
;(define-struct prolog (misc dtd misc2))
(define-record-type prolog :prolog
(really-make-prolog misc dtd misc2)
prolog?
(misc prolog-misc)
(dtd prolog-dtd)
(misc2 prolog-misc2))
(define (make-prolog misc dtd . misc2)
(really-make-prolog misc dtd misc2))
;;; Document-type = (make-document-type sym External-dtd #f)
;;; | #f
(define-record-type document-type :document-type
(make-document-type name external inlined)
really-document-type?
(name document-type-name)
(external document-type-external)
(inlined document-type-inlined))
;;; External-dtd = (make-external-dtd/public str str)
;;; | (make-external-dtd/system str)
;;; | #f
(define-record-type external-dtd :external-dtd
(make-external-dtd system)
really-external-dtd?
(system really-external-dtd-system))
(define (external-dtd-system external-dtd)
(cond ((really-external-dtd? external-dtd)
(really-external-dtd-system external-dtd))
((external-dtd/public? external-dtd)
(external-dtd/public-system external-dtd))
((external-dtd/system? external-dtd)
(external-dtd/system-system external-dtd))
(else (error "bottom of external-dtd-system" external-dtd))))
(define (external-dtd? obj)
(does-any-satisfy? (list really-external-dtd? external-dtd/public?
external-dtd/system?)
obj))
(define-record-type external-dtd/public :external-dtd/public
(make-external-dtd/public system public)
external-dtd/public?
(system external-dtd/public-system)
(public external-dtd/public-public))
(define-record-type external-dtd/system :external-dtd/system
(make-external-dtd/system system)
external-dtd/system?
(system external-dtd/system-system))
;; Element ::= (make-element Location Location Symbol (listof Attribute) (listof Content))
(define-record-type element :element
(make-element start stop name attributes content)
element?
(start element-start)
(stop element-stop)
(name element-name)
(attributes element-attributes)
(content element-content))
;; Attribute ::= (make-attribute Location Location Symbol String)
(define-record-type attribute :attribute
(make-attribute start stop name value)
attribute?
(start attribute-start)
(stop attribute-stop)
(name attribute-name)
(value attribute-value))
;; Pcdata ::= (make-pcdata Location Location String)
(define-record-type pcdata :pcdata
(make-pcdata start stop string)
pcdata?
(start pcdata-start)
(stop pcdata-stop)
(string pcdata-string))
;; Content ::= Pcdata
;; | Element
;; | Entity
;; | Misc
;; Misc ::= Comment
;; | Processing-instruction
;; Entity ::= (make-entity Location Location (U Nat Symbol))
(define-record-type entity :entity
(make-entity start stop text)
entity?
(start entity-start)
(stop entity-stop)
(text entity-text))
;; Processing-instruction ::= (make-pi Location Location String (list String))
;; also represents XMLDecl
(define-record-type pi :pi
(make-pi start stop target-name instruction)
pi?
(start pi-start)
(stop pi-stop)
(target-name pi-target-name)
(instruction pi-instruction))
;; Comment ::= (make-comment String)
(define-record-type comment :comment
(make-comment text)
comment?
(text comment-text))
;; content? : TST -> Bool
(define (content? x)
(or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x)))
;;; moved here from reader as it inherits from source
;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute))
(define-record-type start-tag :start-tag
(make-start-tag start stop name attrs)
start-tag?
(start start-tag-start)
(stop start-tag-stop)
(name start-tag-name)
(attrs start-tag-attrs))
;; End-tag ::= (make-end-tag Location Location Symbol)
(define-record-type end-tag :end-tag
(make-end-tag start stop name)
end-tag?
(start end-tag-start)
(stop end-tag-stop)
(name end-tag-name))

155
scheme/xml/writer.scm
View File

@ -1,155 +0,0 @@
;;(define empty-tag-shorthand (make-parameter #t))
;;(define empty-tag-shorthand (make-parameter void))
;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol))
(define empty-tag-shorthand
(make-parameter 'always
(lambda (x)
(if (or (eq? x 'always) (eq? x 'never) (and (list? x) (andmap symbol? x)))
x
(error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~a" x)))))
(define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area))
;; var-argify : (a Output-port -> b) -> (a [Output-port] -> b)
(define (var-argify f)
(lambda (x . maybe-port)
(f x (if (null? maybe-port)
(current-output-port)
(car maybe-port)))))
;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void
(define (gen-write/display-xml/content dent)
(var-argify (lambda (c out)
(write-xml-content c 0 dent out))))
;; indent : Nat Output-port -> Void
(define (indent n out)
(newline out)
(let loop ((n n))
(unless (zero? n)
(display #\space out)
(loop (sub1 n)))))
;; write-xml/content : Content [Output-port] -> Void
(define write-xml/content (gen-write/display-xml/content void))
;; display-xml/content : Content [Output-port] -> Void
(define display-xml/content (gen-write/display-xml/content indent))
;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void
(define (gen-write/display-xml output-content)
(var-argify (lambda (doc out)
(let ((prolog (document-prolog doc)))
(display-outside-misc (prolog-misc prolog) out)
(display-dtd (prolog-dtd prolog) out)
(display-outside-misc (prolog-misc2 prolog) out))
(output-content (document-element doc) out)
(display-outside-misc (document-misc doc) out))))
; display-dtd : document-type oport -> void
(define (display-dtd dtd out)
(when dtd
(fprintf out "<!DOCTYPE ~a" (document-type-name dtd))
(let ((external (document-type-external dtd)))
(cond
((external-dtd/public? external)
(fprintf out " PUBLIC \"~a\" \"~a\""
(external-dtd/public-public external)
(external-dtd-system external)))
((external-dtd/system? external)
(fprintf out " SYSTEM \"~a\"" (external-dtd-system external)))
((not external) (void))))
(display ">" out)
(newline out)))
;; write-xml : Document [Output-port] -> Void
(define write-xml (gen-write/display-xml write-xml/content))
;; display-xml : Document [Output-port] -> Void
(define display-xml (gen-write/display-xml display-xml/content))
;; display-outside-misc : (listof Misc) Output-port -> Void
(define (display-outside-misc misc out)
(for-each (lambda (x)
((cond
((comment? x) write-xml-comment)
((pi? x) write-xml-pi)
(else (error "bottom " x))) x 0 void out)
(newline out))
misc))
;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-content el over dent out)
((cond
((element? el) write-xml-element)
((pcdata? el) write-xml-pcdata)
((entity? el) write-xml-entity)
((comment? el) write-xml-comment)
((pi? el) write-xml-pi)
(else (error 'write-xml-content "received ~a" el)))
el over dent out))
;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-element el over dent out)
(let* ((name (element-name el))
(start (lambda (f) (write-xml-base (format f name) over dent out)))
(content (element-content el)))
(start "<~a")
(for-each (lambda (att)
(fprintf out " ~s=~s" (attribute-name att)
(escape (attribute-value att) escape-attribute-table)))
(element-attributes el))
(if (and (null? content)
(let ((short (empty-tag-shorthand)))
(case short
((always) #t)
((never) #f)
(else (memq name short)))))
(fprintf out " />")
(begin
(fprintf out ">")
(for-each (lambda (c) (write-xml-content c (incr over) dent out)) content)
(start "</~a")
(fprintf out ">")))))
;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-base el over dent out)
(dent over out)
(display el out))
;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-pcdata str over dent out)
(write-xml-base (escape (pcdata-string str) escape-table) over dent out))
;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-pi pi over dent out)
(write-xml-base (format "<?~a ~a?>" (pi-target-name pi) (pi-instruction pi)) over dent out))
;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void
(define (write-xml-comment comment over dent out)
(write-xml-base (format "<!--~a-->" (comment-text comment)) over dent out))
;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void
(define (write-xml-entity entity over dent out)
(let ((n (entity-text entity)))
(fprintf out (if (number? n) "&#~a;" "&~a;") n)))
(define escape-table
(map (lambda (x y) (cons (regexp (symbol->string x)) y))
'(< > &)
'("&lt;" "&gt;" "&amp;")))
(define escape-attribute-table
(list* (cons (regexp "'") "&apos;") (cons (regexp "\"") "&quot;") escape-table))
;; escape : String -> String
;; more here - this could be much more efficient
(define (escape x table)
(foldr (lambda (esc str) (regexp-replace* (car esc) str (cdr esc)))
x
table))
;; incr : Nat -> Nat
(define (incr n) (+ n 2))

81
scheme/xml/xexpr.scm
View File

@ -1,81 +0,0 @@
; (import xml-structs^ writer^ mzlib:function^)
;; Xexpr ::= String
;; | (list* Symbol (listof Attribute-srep) (listof Xexpr))
;; | (cons Symbol (listof Xexpr))
;; | Symbol
;; | Nat
;; | Comment
;; | Processing-instruction
;; Attribute-srep ::= (list Symbol String)
;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts.
;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a))
(define (assoc-sort to-sort)
(quicksort to-sort (bcompose string<? (compose symbol->string car))))
(define xexpr-drop-empty-attributes (make-parameter #f))
;; xml->xexpr : Content -> Xexpr
;; The contract is loosely enforced.
(define (xml->xexpr x)
(let* ((non-dropping-combine
(lambda (atts body)
(cons (assoc-sort (map attribute->srep atts))
body)))
(combine (if (xexpr-drop-empty-attributes)
(lambda (atts body)
(if (null? atts)
body
(non-dropping-combine atts body)))
non-dropping-combine)))
(let loop ((x x))
(cond
((element? x)
(let ((body (map loop (element-content x)))
(atts (element-attributes x)))
(cons (element-name x) (combine atts body))))
((pcdata? x) (pcdata-string x))
((entity? x) (entity-text x))
((or (comment? x) (pi? x)) x)
((document? x) (error 'xml->xexpr "Expected content, given ~a~nUse document-element to extract the content." x))
(else (error 'xml->xexpr "Expected content, given ~a" x))))))
;; attribute->srep : Attribute -> Attribute-srep
(define (attribute->srep a)
(list (attribute-name a) (attribute-value a)))
;; srep->attribute : Attribute-srep -> Attribute
(define (srep->attribute a)
(unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a)))
(error 'srep->attribute "expected (cons Symbol String) given ~a" a))
(make-attribute 'scheme 'scheme (car a) (cadr a)))
;; xexpr->xml : Xexpr -> Content
;; The contract is enforced.
(define (xexpr->xml x)
(cond
((pair? x)
(let ((f (lambda (atts body)
(unless (list? body)
(error 'xexpr->xml "expected a list of xexprs a the body in ~a" x))
(make-element 'scheme 'scheme (car x)
atts
(map xexpr->xml body)))))
(if (and (pair? (cdr x)) (or (null? (cadr x)) (and (pair? (cadr x)) (pair? (caadr x)))))
(f (map srep->attribute (cadr x)) (cddr x))
(f null (cdr x)))))
((string? x) (make-pcdata 'scheme 'scheme x))
((or (symbol? x) (and (integer? x) (>= x 0))) (make-entity 'scheme 'scheme x))
((or (comment? x) (pi? x)) x)
(else (error 'xexpr->xml "malformed xexpr ~s" x))))
;; xexpr->string : Xexpression -> String
(define (xexpr->string xexpr)
(let ((port (open-output-string)))
(write-xml/content (xexpr->xml xexpr) port)
(get-output-string port)))
;; bcompose : (a a -> c) (b -> a) -> (b b -> c)
(define (bcompose f g)
(lambda (x y) (f (g x) (g y))))

128
scheme/xml/xml-packages.scm
View File

@ -1,128 +0,0 @@
(define-interface xml-structures-interface
(export source-start
source-stop
make-location location? location-line location-char location-offset
make-document document? document-prolog document-element document-misc
make-prolog prolog? prolog-misc prolog-dtd prolog-misc2
make-document-type document-type-name document-type-external
external-dtd-system external-dtd/system?
make-external-dtd/public external-dtd/public? external-dtd/public-public
make-external-dtd/system
make-element element? element-name element-attributes element-content
make-attribute attribute? attribute-name attribute-value
make-pcdata pcdata? pcdata-string
make-entity entity? entity-text
make-pi pi? pi-target-name pi-instruction
make-comment comment? comment-text
content?
make-start-tag start-tag? start-tag-name start-tag-attrs
make-end-tag end-tag? end-tag-name))
(define-structure xml-structures xml-structures-interface
(open scheme
signals
extended-ports
define-record-types)
(files structures))
(define-interface plt-compat-interface
(export let-values
let*-values
add1 sub1
when unless
begin0
void
andmap
quicksort
make-parameter
let/ec call/ec
list* null
format
fprintf
regexp regexp-replace*
foldr
compose
open-output-string get-output-string
))
(define-structure plt-compat plt-compat-interface
(open scsh
scheme
string-lib
structure-refs)
(access big-scheme ;; format
list-lib) ;; fold
(files plt))
(define-interface reader-interface
(export read-xml
read-comments
collapse-whitespace))
(define-structure reader reader-interface
(open scsh ;read-string
scheme
xml-structures
i/o
i/o-internal
ports
plt-compat
byte-vectors
signals)
(files reader))
(define-interface writer-interface
(export write-xml
display-xml
write-xml/content
display-xml/content
empty-tag-shorthand
html-empty-tags))
(define-structure writer writer-interface
(open scheme
xml-structures
signals
plt-compat)
(files writer))
(define-interface space-interface
(export eliminate-whitespace))
(define-structure space space-interface
(open scheme
plt-compat
signals
list-lib
xml-structures)
(files space))
(define-interface xexpr-interface
(export xml->xexpr
xexpr->xml
xexpr->string
xexpr-drop-empty-attributes))
(define-structure xexpr xexpr-interface
(open scheme
plt-compat
writer
signals
xml-structures)
(files xexpr))
(define-structure xml (compound-interface xml-structures-interface
reader-interface
writer-interface
xexpr-interface
space-interface)
(open scheme
plt-compat
xml-structures
reader
writer
xexpr
space))

157
start-extended-web-server
View File

@ -1,157 +0,0 @@
#!/bin/sh
echo "Loading..."
exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
!#
(define-structure http-test
(export main)
(open httpd-core
httpd-make-options
httpd-basic-handlers
httpd-file-directory-handlers
cgi-server
seval-handler
rman-gateway
info-gateway
let-opt
scsh
scheme)
(begin
(define (usage)
(format #f
"Usage: start-web-server [-h htdocs-dir] [-c cgi-bin-dir] [-p port]
[-l log-file-name] [-r requests] [--help]
with
htdocs-dir directory of html files (default: web-server/root/htdocs)
cgi-bin-dir directory of cgi files (default: web-server/root/cgi-bin)
port port server is listening to (default: 8080)
log-file-name directory where to store the logfile in CLF
(default: web-server/httpd.log)
requests maximal amount of simultaneous requests (default 5)
--help show this help
"
))
(define htdocs-dir #f)
(define cgi-bin-dir #f)
(define port #f)
(define log-file-name #f)
(define root #f)
(define simultaneous-requests #f)
(define (init)
(set! htdocs-dir "web-server/root/htdocs")
(set! cgi-bin-dir "web-server/root/cgi-bin")
(set! port "8080")
(set! log-file-name "web-server/httpd.log")
(set! root "web-server/root")
(set! simultaneous-requests "5"))
(define get-options
(let* ((unknown-option-error
(lambda (option)
(format (error-output-port)
"unknown option `~A'~%try `start-web-server --help'~%"
option)
(exit 1)))
(missing-argument-error
(lambda (option)
(format (error-output-port)
"option `~A' requires an argument~%try `start-web-server --help'~%"
option)
(exit 1))))
(lambda (options)
(let loop ((options options))
(if (null? options)
(begin
(set! htdocs-dir (absolute-file-name htdocs-dir))
(set! log-file-name (absolute-file-name log-file-name))
(set! cgi-bin-dir (absolute-file-name cgi-bin-dir))
(set! port (string->number port))
(set! simultaneous-requests (string->number simultaneous-requests)))
(cond
((string=? (car options) "-h")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! htdocs-dir (cadr options)))
(loop (cddr options)))
((string=? (car options) "-c")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! cgi-bin-dir (cadr options)))
(loop (cddr options)))
((string=? (car options) "-p")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! port (cadr options)))
(loop (cddr options)))
((string=? (car options) "-l")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! log-file-name (cadr options)))
(loop (cddr options)))
((string=? (car options) "-r")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! simultaneous-requests (cadr options)))
(loop (cddr options)))
((string=? (car options) "--help")
(display (usage))
(exit 0))
((string=? (car options) "--dump")
(let ((image-name (if (null? (cdr options))
"server"
(cadr options))))
(dump-scsh-program main image-name))
(exit 0))
(else
(unknown-option-error (car options)))))))))
(define (main args)
(init)
(format #t "reading options: ~s~%" (cdr args))
(get-options (cdr args))
(cond ((zero? (user-uid))
(set-gid (->gid "nobody"))
(set-uid (->uid "nobody"))))
(format #t "Going to run Webserver with:
htdocs-dir: ~a
cgi-bin-dir: ~a
port: ~a
log-file-name: ~a
a maximum of ~a simultaneous requests, syslogging activated,
and home-dir-handler (public_html) activated.
"
htdocs-dir
cgi-bin-dir
port
log-file-name
simultaneous-requests)
(httpd (with-port port
(with-root-directory (cwd)
(with-simultaneous-requests simultaneous-requests
(with-syslog? #t
(with-logfile log-file-name
(with-request-handler
(alist-path-dispatcher
(list (cons "h" (home-dir-handler "public_html"))
(cons "seval" seval-handler)
(cons "man" (rman-handler #f "man?%s(%s)"
"Generated by rman-gateway"))
(cons "info" (info-handler #f #f #f
"Generated by info-gateway"))
(cons "cgi-bin" (cgi-handler cgi-bin-dir)))
(rooted-file-or-directory-handler htdocs-dir))))))))))
))
;; EOF
;;; Local Variables:
;;; mode:scheme
;;; End:

134
start-web-server
View File

@ -1,134 +0,0 @@
#!/bin/sh
echo "Loading..."
exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
!#
(define-structure http-test
(export main)
(open httpd-core
httpd-make-options
httpd-basic-handlers
httpd-file-directory-handlers
httpd-cgi-handlers
scheme-with-scsh)
(begin
(define (usage)
(format #f
"Usage: start-web-server [-h htdocs-dir] [-c cgi-bin-dir] [-p port]
[-l log-file-name] [--help]
with
htdocs-dir directory of html files (default: web-server/root/htdocs)
cgi-bin-dir directory of cgi files (default: web-server/root/cgi-bin)
port port server is listening to (default: 8080)
log-file-name directory where to store the logfile in CLF
(default: web-server/httpd.log)
--help show this help
"
))
(define htdocs-dir #f)
(define cgi-bin-dir #f)
(define port #f)
(define log-file-name #f)
(define root #f)
(define (init)
(set! htdocs-dir "web-server/root/htdocs")
(set! cgi-bin-dir "web-server/root/cgi-bin")
(set! port "8080")
(set! log-file-name "web-server/httpd.log")
(set! root "web-server/root"))
(define get-options
(let* ((unknown-option-error
(lambda (option)
(format (error-output-port)
"unknown option `~A'~%try `start-web-server --help'~%"
option)
(exit 1)))
(missing-argument-error
(lambda (option)
(format (error-output-port)
"option `~A' requires an argument~%try `start-web-server --help'~%"
option)
(exit 1))))
(lambda (options)
(let loop ((options options))
(if (null? options)
(begin
(set! htdocs-dir (absolute-file-name htdocs-dir))
(set! log-file-name (absolute-file-name log-file-name))
(set! cgi-bin-dir (absolute-file-name cgi-bin-dir))
(set! port (string->number port)))
(cond
((string=? (car options) "-h")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! htdocs-dir (cadr options)))
(loop (cddr options)))
((string=? (car options) "-c")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! cgi-bin-dir (cadr options)))
(loop (cddr options)))
((string=? (car options) "-p")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! port (cadr options)))
(loop (cddr options)))
((string=? (car options) "-l")
(if (null? (cdr options))
(missing-argument-error (car options))
(set! log-file-name (cadr options)))
(loop (cddr options)))
((string=? (car options) "--help")
(display (usage))
(exit 0))
((string=? (car options) "--dump")
(let ((image-name (if (null? (cdr options))
"web-server"
(cadr options))))
(dump-scsh-program main image-name))
(exit 0))
(else
(unknown-option-error (car options)))))))))
(define (main args)
(init)
(format #t "reading options: ~s~%" (cdr args))
(get-options (cdr args))
(cond ((zero? (user-uid))
(set-gid (->gid "nobody"))
(set-uid (->uid "nobody"))))
(format #t "Going to run Webserver with:
htdocs-dir: ~a
cgi-bin-dir: ~a
port: ~a
log-file-name: ~a
syslogging activated.
"
htdocs-dir
cgi-bin-dir
port
log-file-name)
(httpd (with-port port
(with-root-directory (cwd)
(with-syslog? #t
(with-logfile log-file-name
(with-request-handler
(tilde-home-dir-handler "public_html"
(alist-path-dispatcher
(list (cons "cgi-bin" (cgi-handler cgi-bin-dir)))
(rooted-file-or-directory-handler htdocs-dir))))))))))
))
;; EOF
;;; Local Variables:
;;; mode:scheme
;;; End:

1
web-server/.gitignore vendored
View File

@ -1 +0,0 @@
httpd.log

9
web-server/root/cgi-bin/comments.sh
View File

@ -1,9 +0,0 @@
#!/bin/sh
# An example CGI program outputing the current date
echo Content-Type: text/html
echo Status: 200 OK
echo
echo "<h2> This is the cgi script. </h2>"
echo "<br> Current date: "
echo `date`
echo

3
web-server/root/cgi-bin/move.sh
View File

@ -1,3 +0,0 @@
#!/bin/sh
# Example for server redirection
echo Location:http://www.scsh.net/resources/sunet.html

1
web-server/root/htdocs/files/text.txt
View File

@ -1 +0,0 @@
This is a text file.

BIN
web-server/root/htdocs/files/zipped.gz
View File

Binary file not shown.

8
web-server/root/htdocs/index.html
View File

@ -1,8 +0,0 @@
<html>
<head><title>Home</title></head>
<body>
<p>
Hello world! <a href=index2.html>(more...)</a>
</p>
</body>
</html>

39
web-server/root/htdocs/index2.html
View File

@ -1,39 +0,0 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head><title>Scheme Unterground</title></head>
<body>
<p>
<h1>Hello Unterground!</h1>
Following files are available:
<ul>
<li><a href=/manual/man.html>SUnet release manual</a></li>
<li><a href=../cgi-bin/comments.sh>A small CGI script</a></li>
<li><a href=seval.html>Computing Scheme Forms
Interactively</a></li>
<li><a href=man?man>Get a man page</a><br>
(needs a matching man page installation;<br>
&nbsp;see httpd/rman-gateway.scm for details)</li>
<li><a href=info?(dir)Top>Get the dir info page</a><br>
(needs a matching info page installation;<br>
&nbsp;among others, we need non-gzipped info pages)</li>
<li><a href=files/text.txt>Text file</a></li>
<li><a href=files>Directory</a></li>
<li><a href=files/zipped.gz>Compressed File</a></li>
<li><a href=index.html>Start</a></li>
<li><a href=index2.html>This file</a></li>
</ul>
<br>
And nothing else...
<hr>
<!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
<!-- hhmts start -->
Last modified: Wed Jan 15 16:16:58 MET 2003
<!-- hhmts end -->
</body>
</html>
</p>
</body>
</html>

25
web-server/root/htdocs/seval.html
View File

@ -1,25 +0,0 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<title>Evaluating Scheme Expressions Interactively</title>
</head>
<body>
<h1>Evaluating Scheme Expressions Interactively</h1>
<form action="seval" method="post">
Type in your scheme expression as you would at any REPL:
<br>
<input type="text" name="program">
<input type="submit">
<input type="reset">
</form>
<hr>
<address><a href="mailto:andreas.bernauer@gmx.de">Andreas Bernauer</a></address>
<!-- Created: Wed Aug 28 16:35:32 CEST 2002 -->
<!-- hhmts start -->
Last modified: Wed Aug 28 16:40:54 CEST 2002
<!-- hhmts end -->
</body>
</html>