Compare commits
1 Commits
main
...
surflet-se
| Author | SHA1 | Date |
|---|---|---|
cvs-fast-export
|
e1ec98d90b |
|
|
@ -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
27
COPYING
|
|
@ -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
47
Makefile
|
|
@ -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
47
Readme
|
|
@ -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.
|
||||
|
|
@ -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>
|
||||
|
||||
|
||||
|
|
@ -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>
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
*.aux
|
||||
*.toc
|
||||
*.dvi
|
||||
*.ps
|
||||
*.pdf
|
||||
*.log
|
||||
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../web-server/root/htdocs/sunet-manual
|
||||
|
|
@ -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:
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
|
@ -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}
|
||||
|
|
@ -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
|
||||
|
|
@ -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:
|
||||
|
|
@ -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:
|
||||
|
||||
|
|
@ -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:
|
||||
|
|
@ -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
|
||||
|
|
@ -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:
|
||||
|
|
@ -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:
|
||||
|
|
@ -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}}
|
||||
}
|
||||
|
|
@ -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}
|
||||
|
|
@ -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{}
|
||||
|
|
@ -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}
|
||||
|
|
@ -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
|
||||
|
|
@ -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:
|
||||
|
|
@ -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:
|
||||
|
|
@ -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
|
||||
|
|
@ -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:
|
||||
|
|
@ -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:
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
\section{Section-Title}
|
||||
%
|
||||
\begin{description}
|
||||
\item[Used files:]
|
||||
\item[Name of the package:]
|
||||
\end{description}
|
||||
%
|
||||
Not implemented yet.
|
||||
|
|
@ -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:
|
||||
|
|
@ -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:
|
||||
|
|
@ -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
1324
scheme/ftpd/ftpd.scm
File diff suppressed because it is too large
Load Diff
|
|
@ -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)))))
|
||||
|
|
@ -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
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
@ -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))))
|
||||
|
||||
|
|
@ -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))
|
||||
|
|
@ -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")))
|
||||
|
||||
|
|
@ -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)))))))))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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))))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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")))
|
||||
|
|
@ -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")))))))
|
||||
|
|
@ -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."))))
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
1567
scheme/lib/dns.scm
File diff suppressed because it is too large
Load Diff
|
|
@ -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))))
|
||||
|
||||
|
|
@ -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))))
|
||||
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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 ...))))
|
||||
|
|
@ -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 ...])
|
||||
| </ | ||||