.
-
-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.
\ No newline at end of file
diff --git a/doc/html/index.html b/doc/html/index.html
deleted file mode 100644
index 0b8e359..0000000
--- a/doc/html/index.html
+++ /dev/null
@@ -1,85 +0,0 @@
-
-
-The Scheme Underground Network Package
-
-
-
-The Scheme Underground Network Package
-I have written a set of libraries 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.
-
-
- The SU Web server
-
- 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:
-
- - 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.
-
- The server has three main design goals:
-
- - Extensibility
-
- 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.
-
-
- 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.
-
-
- Mobile code
-
- 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.)
-
-
-
- Clarity
-
- 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.
-
-
-
- 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.
-
-
- Some simple documentation on the server
- is available.
-
-
-
-Obtaining the system
-The network code is available by
-ftp.
-To run the server, you need our 0.4 release of
-scsh
-which has just been released.
-
-Beyond actually running the server,
-the separate parser libraries and other utilites may be of use as separate
-modules.
-
-Olin Shivers
- / shivers@ai.mit.edu
-
-
-
-
-
diff --git a/doc/html/su-httpd.html b/doc/html/su-httpd.html
deleted file mode 100644
index 356aa37..0000000
--- a/doc/html/su-httpd.html
+++ /dev/null
@@ -1,482 +0,0 @@
-
-
-
-The Scheme Underground Web system
-
-
-
-The Scheme Underground Web System
-
-Olin Shivers
- / shivers@ai.mit.edu
-
-July 1995
-
-
-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
-ASCII version of this note, instead.
-
-
-
-
-
-Introduction
-
-The
-Scheme underground
-Web system is a package of
-Scheme
-code that provides
-utilities for interacting with the
-World-Wide Web.
-This includes:
-
-- A Web server.
-
- URI and URL parsers and un-parsers.
-
- RFC822-style header parsers.
-
- Code for performing structured html output
-
- 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).
-
-
-
-The code can be obtained via
-
-anonymous ftp
-and is implemented in
-Scheme 48,
-using the system calls and support procedures of
-scsh,
-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.
-
-
-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.
-
-
The Scheme Underground Web Server
-
-The server was designed with three principle goals in mind:
-
-- Extensibility
-
- 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."
-
-
-
- Mobile code
-
- 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.
-
-
-
- Clarity of implementation
-
- 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.
-
-
-
-Basic server structure
-
-The Web server is started by calling the httpd procedure,
-which takes one required and two optional arguments:
-
- (httpd path-handler [port working-directory])
-
-
-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
-
- /usr/local/etc/httpd
-
-
-
-
-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 httpd).
-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.
-
-
-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.
-
-
-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.
-
-
-
-
Path handlers
-
-A path handler is a procedure taking two arguments:
-
- (path-handler path req)
-
-
-
-The req argument is a request record giving all the details of the
-client's request; it has the following structure:
-
- (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.
-
-
-The path argument is the URL's path,
-parsed and split at slashes into a string list.
-For example, if the Web client dereferences URL
-
- http://clark.lcs.mit.edu:8001/h/shivers/code/web.tar.gz
-
-then the server would pass the following path to the top-level handler:
-
- ("h" "shivers" "code" "web.tar.gz")
-
-
-
-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.
-
-
-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
-not 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.
-
-
-
Basic path handlers
-
-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:
-
-
-
--
-
(alist-path-dispatcher ph-alist default-ph) -> path-handler
-
- -
- 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
-
("foo" "bar" "baz"),
- it uses the first element of the path -- "foo" -- 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, ("bar" "baz").
- 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, ("foo" "bar" "baz").
-
-
- 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.
-
-
- 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.
-
-
- Example:
- A typical top-level path handler is
-
-
- (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")))
-
-
- This means:
-
-- If the path looks like
("h" "shivers" "code" "web.tar.gz"),
- pass the path ("shivers" "code" "web.tar.gz") to a
- home-directory path handler.
-
-
- - If the path looks like
("cgi-bin" "calendar"),
- pass ("calendar") off to the CGI path handler.
-
-
- - If the path looks like
("seval" ...),
- the tail of the path is passed off to the code-uploading seval
- path handler.
-
- - Otherwise, the whole path is passed to a rooted file handler, who
- will convert it into a filename, rooted at
-
/usr/local/etc/httpd/htdocs, and serve that file.
-
-
-
- -
(home-dir-handler subdir) ->
- path-handler
- -
- 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
(user . file-path),
- then it serves the file
-
- user's-home-directory/subdir/file-path
-
- The path handler only handles GET requests; the filename is not
- allowed to contain .. elements.
-
-
- -
-
(tilde-home-dir-handler subdir default-path-handler)
- -> path-handler
-
- -
- This path handler examines the car of the path. If it is a string
- beginning with a tilde, e.g., "
~ziggy",
- then the string is taken
- to mean a home directory, and the request is served similarly to a
- home-dir-handler path handler.
- Otherwise, the request is passed off
- in its entirety to the default path handler.
-
-
- This procedure is useful for implementing servers that provide the
- semantics of the NCSA httpd server.
-
-
-
-
-
(cgi-handler cgi-directory) -> path-handler
-
- -
- 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
..'s.
- If the path is
-
- ("my-prog" "foo" "bar")
-
- then the program executed is
-
- cgi-directory/my-prog
-
-
- When the CGI path handler builds the process environment for the
- CGI script, several elements
- (e.g., $PATH and $SERVER_SOFTWARE)
- are request-invariant, and can be computed at server start-up time.
- This can be done by calling
-
- (initialise-request-invariant-cgi-env)
-
- when the server starts up. This is not necessary,
- but will make CGI requests a little faster.
-
-
- -
-
(rooted-file-handler root-dir) -> path-handler
-
- -
- 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 root-dir.
- The file name is checked for
.. components,
- and the transaction is aborted if it does. Otherwise, the file is
- served to the client.
-
- -
-
(null-path-handler path req)
- -
- This path handler is useful as a default handler. It handles no requests,
- always returning a "404 Not found" reply to the client.
-
-
-
-
-HTTP errors
-
-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 http-error 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.
-
-
-
--
-
(http-error reply-code req [extra ...])
- -
- This raises an http error condition. The reply code is one of the
- numeric HTTP error reply codes, which are bound to the variables
-
http-reply/ok, http-reply/not-found,
- http-reply/bad-request, and so
- forth. The req argument is the request record that caused
- the error.
- Any following extra 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 extra values as the
- URI: and Location:
- fields in the reply header, respectively. See the clauses of the
- send-http-error-reply procedure for details.
-
-
- -
-
(send-http-error-reply reply-code request
- [extra ...])
-
- -
- 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.
-
-
-
-Simple directory generation
-
-Most path-handlers that serve files to clients eventually call an internal
-procedure named file-serve,
-which implements a simple directory-generation service using the
-following rules:
-
-
-
-
-Support procs
-
-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.
-
-
-
-Losing
-
-Be aware of two Unix problems, which may require workarounds:
-
-
--
- NeXTSTEP's Posix implementation of the
getpwnam() routine
- will silently tell you that every user has uid 0. This means
- that if your server, running as root, does a
-
- (set-uid (user->uid "nobody"))
-
- it will essentially do a
-
- (set-uid 0)
-
- and you will thus still be running as root.
-
-
- 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:
-
- (set-uid -2)
-
- This problem is NeXTSTEP specific. If you are using not using NeXTSTEP,
- no problem.
-
-
- -
- On NeXTSTEP, the ip-address->host-name translation routine
- (in C,
gethostbyaddr(); in scsh,
- (host-info addr)) 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.
-
-
- This problem may occur on other OS's;
- I cannot determine if gethostbyaddr()
- 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.)
-
-
- If your system doesn't give you a complete Internet address when
- you say
-
- (host-info:name (host-info (system-name)))
-
- then you have this problem.
-
-
- The server has a workaround. There is a procedure exported from
- the httpd-core package:
-
- (set-my-fqdn name)
-
- Call this to crow-bar the server's idea of its own Internet host name
- before running the server, and all will be well.
-
-
-
-
diff --git a/doc/latex/.gitignore b/doc/latex/.gitignore
deleted file mode 100644
index 0454526..0000000
--- a/doc/latex/.gitignore
+++ /dev/null
@@ -1,7 +0,0 @@
-*.aux
-*.toc
-*.dvi
-*.ps
-*.pdf
-*.log
-
diff --git a/doc/latex/.tex2page.hdir b/doc/latex/.tex2page.hdir
deleted file mode 100644
index aaa8dd6..0000000
--- a/doc/latex/.tex2page.hdir
+++ /dev/null
@@ -1 +0,0 @@
-../../web-server/root/htdocs/sunet-manual
diff --git a/doc/latex/cgi-script.tex b/doc/latex/cgi-script.tex
deleted file mode 100644
index e846a7d..0000000
--- a/doc/latex/cgi-script.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/code.sty b/doc/latex/code.sty
deleted file mode 100644
index 2786d61..0000000
--- a/doc/latex/code.sty
+++ /dev/null
@@ -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] 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.
diff --git a/doc/latex/css.t2p b/doc/latex/css.t2p
deleted file mode 100644
index 7c1fcee..0000000
--- a/doc/latex/css.t2p
+++ /dev/null
@@ -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
\ No newline at end of file
diff --git a/doc/latex/ct.sty b/doc/latex/ct.sty
deleted file mode 100644
index 1edfbc0..0000000
--- a/doc/latex/ct.sty
+++ /dev/null
@@ -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}
diff --git a/doc/latex/decls.tex b/doc/latex/decls.tex
deleted file mode 100644
index 873fcac..0000000
--- a/doc/latex/decls.tex
+++ /dev/null
@@ -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{\}}
-\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 ) -> 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
diff --git a/doc/latex/dns.tex b/doc/latex/dns.tex
deleted file mode 100644
index 7c56859..0000000
--- a/doc/latex/dns.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/ftp.tex b/doc/latex/ftp.tex
deleted file mode 100644
index af7e657..0000000
--- a/doc/latex/ftp.tex
+++ /dev/null
@@ -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:
-
diff --git a/doc/latex/ftpd.tex b/doc/latex/ftpd.tex
deleted file mode 100644
index 7c42e25..0000000
--- a/doc/latex/ftpd.tex
+++ /dev/null
@@ -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 <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:
diff --git a/doc/latex/intro.tex b/doc/latex/intro.tex
deleted file mode 100644
index 0aa445e..0000000
--- a/doc/latex/intro.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/man.t2p b/doc/latex/man.t2p
deleted file mode 100644
index e6a4e80..0000000
--- a/doc/latex/man.t2p
+++ /dev/null
@@ -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}}
-}
diff --git a/doc/latex/man.tex b/doc/latex/man.tex
deleted file mode 100644
index c05625f..0000000
--- a/doc/latex/man.tex
+++ /dev/null
@@ -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}
diff --git a/doc/latex/mantitle.sty b/doc/latex/mantitle.sty
deleted file mode 100644
index b17f5b5..0000000
--- a/doc/latex/mantitle.sty
+++ /dev/null
@@ -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{}
diff --git a/doc/latex/matter.sty b/doc/latex/matter.sty
deleted file mode 100644
index f0c4fda..0000000
--- a/doc/latex/matter.sty
+++ /dev/null
@@ -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}
diff --git a/doc/latex/mysize10.sty b/doc/latex/mysize10.sty
deleted file mode 100644
index 94c52c0..0000000
--- a/doc/latex/mysize10.sty
+++ /dev/null
@@ -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
diff --git a/doc/latex/netrc.tex b/doc/latex/netrc.tex
deleted file mode 100644
index 76e8b18..0000000
--- a/doc/latex/netrc.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/nettime.tex b/doc/latex/nettime.tex
deleted file mode 100644
index 6b57ede..0000000
--- a/doc/latex/nettime.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/pdfcond.tex b/doc/latex/pdfcond.tex
deleted file mode 100644
index 34d7cf2..0000000
--- a/doc/latex/pdfcond.tex
+++ /dev/null
@@ -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
diff --git a/doc/latex/pop3.tex b/doc/latex/pop3.tex
deleted file mode 100644
index 0458d8d..0000000
--- a/doc/latex/pop3.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/rfc822.tex b/doc/latex/rfc822.tex
deleted file mode 100644
index d5be6c9..0000000
--- a/doc/latex/rfc822.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/skeleton.tex b/doc/latex/skeleton.tex
deleted file mode 100644
index c802198..0000000
--- a/doc/latex/skeleton.tex
+++ /dev/null
@@ -1,8 +0,0 @@
-\section{Section-Title}
-%
-\begin{description}
-\item[Used files:]
-\item[Name of the package:]
-\end{description}
-%
-Not implemented yet.
diff --git a/doc/latex/smtp.tex b/doc/latex/smtp.tex
deleted file mode 100644
index 63fbd13..0000000
--- a/doc/latex/smtp.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/uri.tex b/doc/latex/uri.tex
deleted file mode 100644
index 5516f17..0000000
--- a/doc/latex/uri.tex
+++ /dev/null
@@ -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:
diff --git a/doc/latex/url.tex b/doc/latex/url.tex
deleted file mode 100644
index 687fb1e..0000000
--- a/doc/latex/url.tex
+++ /dev/null
@@ -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:
diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm
deleted file mode 100644
index 4f55961..0000000
--- a/scheme/ftpd/ftpd.scm
+++ /dev/null
@@ -1,1324 +0,0 @@
-; RFC 959 ftp daemon
-
-;;; This file is part of the Scheme Untergrund Networking package.
-
-;;; Copyright (c) 1998-2002 by Mike Sperber
-;;; For copyright information, see the file COPYING which comes with
-;;; the distribution.
-
-; It doesn't support the following desirable things:
-;
-; - Login by user
-; - RESTART support
-; - Banners from files on CWD
-; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/
-
-
-; following things should be improved:
-;
-; - GET/RETR-command: ftpd reports "Can't open FILENAME for reading" if
-; file actually doesn't exist. This is confusing. Reporting
-; "FILENAME does not exist" is much better.
-; - default value for ftpd should be looked up as in ftp.scm
-
-(define-record-type ftpd-options :ftpd-options
- (really-make-ftpd-options port anonymous-home banner
- logfile dns-lookup?)
- ftpd-options?
- (port ftpd-options-port set-ftpd-options-port!)
- (anonymous-home ftpd-options-anonymous-home set-ftpd-options-anonymous-home!)
- (banner ftpd-options-banner set-ftpd-options-banner!)
- (logfile ftpd-options-logfile set-ftpd-options-logfile!)
- (dns-lookup? ftpd-options-dns-lookup? set-ftpd-options-dns-lookup?!))
-
-(define (make-default-ftpd-options)
- (really-make-ftpd-options 21
- "~ftp"
- (string-append "Scheme Untergrund ftp server (version "
- sunet-version-identifier
- ") ready.")
- #f
- #f))
-
-(define (copy-ftpd-options options)
- (really-make-ftpd-options (ftpd-options-port options)
- (ftpd-options-anonymous-home options)
- (ftpd-options-banner options)
- (ftpd-options-logfile options)
- (ftpd-options-dns-lookup? options)))
-
-(define (make-ftpd-options-transformer set-option!)
- (lambda (new-value . stuff)
- (let ((new-options (if (not (null? stuff))
- (copy-ftpd-options (car stuff))
- (make-default-ftpd-options))))
- (set-option! new-options new-value)
- new-options)))
-
-(define with-port
- (make-ftpd-options-transformer set-ftpd-options-port!))
-(define with-anonymous-home
- (make-ftpd-options-transformer set-ftpd-options-anonymous-home!))
-(define with-banner
- (make-ftpd-options-transformer set-ftpd-options-banner!))
-(define with-logfile
- (make-ftpd-options-transformer set-ftpd-options-logfile!))
-(define with-dns-lookup?
- (make-ftpd-options-transformer set-ftpd-options-dns-lookup?!))
-
-(define (make-ftpd-options . stuff)
- (let loop ((options (make-default-ftpd-options))
- (stuff stuff))
- (if (null? stuff)
- options
- (let* ((transformer (car stuff))
- (value (cadr stuff)))
- (loop (transformer value options)
- (cddr stuff))))))
-
-(define-record-type session :session
- (really-make-session control-input-port
- control-output-port
- logfile-lock
- logged-in?
- authenticated?
- anonymous?
- root-directory
- current-directory
- to-be-renamed
- reverse-replies
- reply-code
- type
- data-socket
- passive-socket
- maybe-log-port)
- session?
- (control-input-port session-control-input-port
- set-session-control-input-port!)
- (control-output-port session-control-output-port
- set-session-control-output-port!)
- (logfile-lock session-logfile-lock)
- (logged-in? session-logged-in?
- set-session-logged-in?!)
- (authenticated? session-authenticated?
- set-session-authenticated?!)
- (anonymous? session-anonymous?
- set-session-anonymous?!)
- (root-directory session-root-directory
- set-session-root-directory!)
- (current-directory session-current-directory
- set-session-current-directory!)
- (to-be-renamed session-to-be-renamed
- set-session-to-be-renamed!)
- (reverse-replies session-reverse-replies
- set-session-reverse-replies!)
- (reply-code session-reply-code
- set-session-reply-code!)
- (type session-type
- set-session-type!)
- (data-socket session-data-socket
- set-session-data-socket!)
- (passive-socket session-passive-socket
- set-session-passive-socket!)
- (maybe-log-port session-maybe-log-port
- set-session-maybe-log-port!))
-
-(define (make-session input-port output-port maybe-log-port)
- (really-make-session input-port output-port
- (make-lock)
- #f ; logged-in?
- #f ; autenticated?
- #f ; anonymous?
- #f ; root-directory
- "" ; current-directory
- #f ; to-be-renamed
- '() ; reverse-replies
- #f ; reply-code
- 'ascii ; type
- #f ; data-socket
- #f ; passive-socket
- maybe-log-port
- ))
-
-(define session (make-fluid #f))
-(define options (make-fluid #f))
-
-(define (make-session-selector selector)
- (lambda ()
- (selector (fluid session))))
-
-(define (make-session-modifier setter)
- (lambda (value)
- (setter (fluid session) value)))
-
-(define the-session-control-input-port
- (make-session-selector session-control-input-port))
-(define the-session-control-output-port
- (make-session-selector session-control-output-port))
-(define the-session-logfile-lock
- (make-session-selector session-logfile-lock))
-
-(define the-session-logged-in? (make-session-selector session-logged-in?))
-(define the-session-authenticated? (make-session-selector session-authenticated?))
-(define the-session-anonymous? (make-session-selector session-anonymous?))
-(define the-session-root-directory (make-session-selector session-root-directory))
-(define the-session-current-directory (make-session-selector session-current-directory))
-(define the-session-to-be-renamed (make-session-selector session-to-be-renamed))
-(define the-session-reverse-replies (make-session-selector session-reverse-replies))
-(define the-session-reply-code (make-session-selector session-reply-code))
-(define the-session-type (make-session-selector session-type))
-(define the-session-data-socket (make-session-selector session-data-socket))
-(define the-session-passive-socket (make-session-selector session-passive-socket))
-(define the-session-maybe-log-port (make-session-selector session-maybe-log-port))
-
-(define set-the-session-control-input-port!
- (make-session-modifier set-session-control-input-port!))
-(define set-the-session-control-output-port!
- (make-session-modifier set-session-control-output-port!))
-(define set-the-session-logged-in?!
- (make-session-modifier set-session-logged-in?!))
-(define set-the-session-authenticated?!
- (make-session-modifier set-session-authenticated?!))
-(define set-the-session-anonymous?!
- (make-session-modifier set-session-anonymous?!))
-(define set-the-session-root-directory!
- (make-session-modifier set-session-root-directory!))
-(define set-the-session-current-directory!
- (make-session-modifier set-session-current-directory!))
-(define set-the-session-to-be-renamed!
- (make-session-modifier set-session-to-be-renamed!))
-(define set-the-session-reverse-replies!
- (make-session-modifier set-session-reverse-replies!))
-(define set-the-session-reply-code!
- (make-session-modifier set-session-reply-code!))
-(define set-the-session-type!
- (make-session-modifier set-session-type!))
-(define set-the-session-data-socket!
- (make-session-modifier set-session-data-socket!))
-(define set-the-session-passive-socket!
- (make-session-modifier set-session-passive-socket!))
-(define set-the-session-maybe-log-port!
- (make-session-modifier set-session-maybe-log-port!))
-
-(define (make-ftpd-options-selector selector)
- (lambda ()
- (selector (fluid options))))
-
-(define the-ftpd-options-port
- (make-ftpd-options-selector ftpd-options-port))
-(define the-ftpd-options-anonymous-home
- (make-ftpd-options-selector ftpd-options-anonymous-home))
-(define the-ftpd-options-banner
- (make-ftpd-options-selector ftpd-options-banner))
-(define the-ftpd-options-logfile
- (make-ftpd-options-selector ftpd-options-logfile))
-(define the-ftpd-options-dns-lookup?
- (make-ftpd-options-selector ftpd-options-dns-lookup?))
-
-;;; LOG -------------------------------------------------------
-(define (log level format-message . args)
- (syslog level
- (apply format #f (string-append "(thread ~D) " format-message)
- (thread-uid (current-thread)) args)))
-
-(define (log-command level command-name . argument)
- (if (null? argument)
- (log level "handling ~A command" command-name)
- (if (not (null? (cdr argument)))
- (log level "handling ~A command with argument ~S"
- command-name argument)
- (log level "handling ~A command with argument ~S" ; does this ever happen?
- command-name (car argument)))))
-
-;; Extended logging like wu.ftpd:
-;; Each file up/download is protocolled
-
-; Mon Dec 3 18:52:41 1990 1 wuarchive.wustl.edu 568881 /files.lst.Z a _ o a chris@wugate.wustl.edu ftp 0 *
-;
-; %.24s %d %s %d %s %c %s %c %c %s %s %d %s
-; 1 2 3 4 5 6 7 8 9 10 11 12 13
-;
-; 1 current time in the form DDD MMM dd hh:mm:ss YYYY
-; 2 transfer time in seconds
-; 3 remote host name
-; 4 file size in bytes
-; 5 name of file
-; 6 transfer type (a>scii, b>inary)
-; 7 special action flags (concatenated as needed):
-; C file was compressed
-; U file was uncompressed
-; T file was tar'ed
-; _ no action taken
-; 8 file was sent to user (o>utgoing) or received from
-; user (i>ncoming)
-; 9 accessed anonymously (r>eal, a>nonymous, g>uest) -- mostly for FTP
-; 10 local username or, if guest, ID string given
-; (anonymous FTP password)
-; 11 service name ('ftp', other)
-; 12 authentication method (bitmask)
-; 0 none
-; 1 RFC931 Authentication
-; 13 authenticated user id (if available, '*' otherwise)
-;
-(define file-log
- (let ((maybe-dns-lookup (lambda (ip)
- (if (the-ftpd-options-dns-lookup?)
- (or (dns-lookup-ip ip)
- ip))
- ip)))
- (lambda (start-transfer-seconds info full-path direction)
- (if (the-session-maybe-log-port)
- (begin
- (obtain-lock (the-session-logfile-lock))
- (format (the-session-maybe-log-port)
- "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%"
- (format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) ; current date and time
- (- (current-seconds) start-transfer-seconds) ; transfer time in secs
- (maybe-dns-lookup
- (socket-address->string
- (socket-remote-address (the-session-data-socket)) #f)) ; remote host ip
- (file-info:size info) ; file size in bytes
- (string-map (lambda (c)
- (if (eq? c #\space) #\_ c))
- full-path) ; name of file (spaces replaced by "_")
- (case (the-session-type)
- ((ascii) "a")
- ((image) "b")
- (else "?")) ; transfer type
- direction ; incoming / outgoing file
- ; anonymous access
- ; password (no password given)
- ; service name
- ; authentication mode
- ; authenticated user id'
- )
- (force-output (the-session-maybe-log-port))
- (release-lock (the-session-logfile-lock)))))))
-
-(define (maybe-open-logfile maybe-logfile)
- (with-errno-handler
- ((errno packet)
- (else
- (format (current-error-port)
- "[ftpd] Warning: Unable to write logs to ~S. Logging is now made to (current-error-port).~%[ftpd] (To disable logging at all, either leave the logfile argument or give #f as logfile)~%"
- maybe-logfile)
- (current-error-port)))
- (and maybe-logfile
- (open-output-file maybe-logfile
- (bitwise-ior open/create open/append)))))
-
-;;; CONVERTERS ------------------------------------------------
-(define (protocol-family->string protocol-family)
- (cond ((= protocol-family protocol-family/unspecified)
- "unspecified")
- ((= protocol-family protocol-family/internet)
- "internet")
- ((= protocol-family protocol-family/unix)
- "unix")
- (else "unknown")))
-
-(define (socket->string socket)
- (format #f
- "family: ~A, ~&local address: ~A, ~&remote address: ~A, ~&input-port ~A, ~&output-port ~A"
- (protocol-family->string (socket:family socket))
- (socket-address->string (socket-local-address socket))
- (socket-address->string (socket-remote-address socket))
- (socket:inport socket)
- (socket:outport socket)))
-
-
-;;; ftpd -------------------------------------------------------
-
-(define (ftpd ftpd-options)
- (display ">>>ftpd ") (write (list (ftpd-options-port ftpd-options))) (newline)
- (with-syslog-destination
- "ftpd"
- #f
- #f
- #f
- (lambda ()
- (log (syslog-level notice)
- "starting daemon on port ~D with ~S as anonymous home and logfile ~S"
- (ftpd-options-port ftpd-options)
- (expand-file-name (ftpd-options-anonymous-home ftpd-options)
- (cwd))
- (ftpd-options-logfile ftpd-options))
- (let ((maybe-log-port (maybe-open-logfile (ftpd-options-logfile ftpd-options))))
- (bind-listen-accept-loop
- protocol-family/internet
- (lambda (socket address)
- (let ((remote-address (socket-address->string address)))
- (set-ftp-socket-options! socket)
- (fork-thread
- (lambda ()
- (handle-connection-encapsulated ftpd-options
- socket
- address
- remote-address
- maybe-log-port)))))
- (ftpd-options-port ftpd-options))))))
-
-(define (handle-connection-encapsulated ftpd-options socket address remote-address maybe-log-port)
- (call-with-current-continuation
- (lambda (exit)
- (with-errno-handler*
- (lambda (errno packet)
- (log (syslog-level notice)
- "error with connection to ~A (~A)"
- remote-address (car packet))
- (exit 'fick-dich-ins-knie))
- (lambda ()
- (let ((socket-string (socket->string socket)))
-
- (log (syslog-level notice)
- "new connection to ~S"
- remote-address)
-
- (log (syslog-level debug) "socket: ~S" socket-string)
-
- (dynamic-wind
- (lambda () 'fick-dich-ins-knie)
- (lambda ()
- (handle-connection ftpd-options
- (socket:inport socket)
- (socket:outport socket)
- maybe-log-port))
- (lambda ()
- (log (syslog-level debug)
- "shutting down socket ~S"
- socket-string)
- (call-with-current-continuation
- (lambda (exit)
- (with-errno-handler*
- (lambda (errno packet)
- (log (syslog-level notice)
- "error shutting down socket to ~A (~A)"
- remote-address (car packet))
- (exit 'fick-dich-ins-knie))
- (lambda ()
- (shutdown-socket socket shutdown/sends+receives)))))
- (log (syslog-level notice)
- "closing connection to ~A and finishing thread" remote-address)
- (log (syslog-level debug)
- "closing socket ~S" socket-string)
- (close-socket socket)))))))))
-
-(define (ftpd-inetd ftpd-options)
- (with-syslog-destination
- "ftpd"
- #f
- #f
- #f
- (lambda ()
- (log (syslog-level notice)
- "starting ftpd from inetd"
- (expand-file-name (ftpd-options-anonymous-home ftpd-options)
- (cwd)))
- (handle-connection ftpd-options
- (current-input-port)
- (current-output-port)
- (maybe-open-logfile (ftpd-options-logfile ftpd-options))))))
-
-(define (set-ftp-socket-options! socket)
- ;; If the client closes the connection, we won't lose when we try to
- ;; close the socket by trying to flush the output buffer.
- ;; ... only it somehow exposes a bug in Windows Internet Explorer
- ;; so we leave it disabled.
- ;; (set-port-buffering (socket:outport socket) bufpol/none)
-
- (set-socket-option socket level/socket tcp/no-delay #t)
-
- (set-socket-option socket level/socket socket/oob-inline #t))
-
-
-(define (handle-connection ftpd-options input-port output-port maybe-log-port)
- (log (syslog-level debug)
- "handling connection with input port ~A, output port ~A"
- input-port
- output-port)
- (call-with-current-continuation
- (lambda (escape)
- (with-handler
- (lambda (condition more)
- (log (syslog-level notice)
- "hit error condition ~A (~S) -- exiting"
- (condition-type condition)
- (condition-stuff condition))
- (escape 'fick-dich-ins-knie))
- (lambda ()
- (let-fluids
- session (make-session input-port output-port maybe-log-port)
- options ftpd-options
- (lambda ()
- (display-banner)
- (handle-commands))))))))
-
-(define (display-banner)
- (log (syslog-level debug)
- "displaying banner (220)")
- (register-reply! 220
- (the-ftpd-options-banner)))
-
-(define-condition-type 'ftpd-quit '())
-(define ftpd-quit? (condition-predicate 'ftpd-quit))
-
-(define-condition-type 'ftpd-irregular-quit '())
-(define ftpd-irregular-quit? (condition-predicate 'ftpd-irregular-quit))
-
-(define-condition-type 'ftpd-error '())
-(define ftpd-error? (condition-predicate 'ftpd-error))
-
-
-(define (handle-commands)
- (log (syslog-level debug) "handling commands")
- (call-with-current-continuation
- (lambda (exit)
- (with-handler
- (lambda (condition more)
- (if (ftpd-quit? condition)
- (begin
- (log (syslog-level debug) "quitting (write-accept-loop)")
- (with-handler
- (lambda (condition ignore)
- (more))
- (lambda ()
- (write-replies)
- (exit 'fick-dich-ins-knie))))
- (more)))
- (lambda ()
- (log (syslog-level debug)
- "starting write-accept-loop")
- (let loop ()
- (write-replies)
- (accept-command)
- (loop)))))))
-
-(define (accept-command)
- (let* ((timeout-seconds 90)
- (command-line (read-crlf-line-timeout (the-session-control-input-port)
- #f
- (* 1000 timeout-seconds);timeout
- 500))) ; max interval
- (log (syslog-level debug)
- "Command line: ~A"
- command-line)
- (cond ((eq? command-line 'timeout)
- (log (syslog-level notice) "hit timelimit of ~D seconds (421)"
- timeout-seconds)
- (log (syslog-level debug)
- "so closing control connection and quitting")
- (register-reply!
- 421
- (format #f "Timeout (~D seconds): closing control connection."
- timeout-seconds)
- (signal 'ftpd-quit)))
- (else
- (call-with-values
- (lambda () (parse-command-line command-line))
- (lambda (command arg)
- (handle-command command arg)))))))
-
-(define (handle-command command arg)
-; (log (syslog-level debug)
-; "handling command ~S with argument ~S"
-; command arg)
- (call-with-current-continuation
- (lambda (escape)
- (with-handler
- (lambda (condition more)
- (cond
- ((error? condition)
- (let ((reason (condition-stuff condition)))
- (log (syslog-level notice)
- "internal error occured: ~S (maybe reason: ~S) -- replying and escaping (451)"
- condition reason)
- (register-reply! 451
- (format #f "Internal error: ~S" reason))
- (escape 'fick-dich-ins-knie)))
- ((ftpd-error? condition)
- ; debug level because nearly every unsuccessful command ends
- ; here (no args, can't change dir, etc.)
- (log (syslog-level debug)
- "ftpd error occured (maybe reason: ~S)-- escaping" (condition-stuff condition))
- (escape 'fick-dich-ins-knie))
- (else
- (more))))
- (lambda ()
- (with-errno-handler*
- (lambda (errno packet)
- (let ((unix-error (car packet)))
- (log (syslog-level notice)
- "unix error occured: ~S -- replying (451) and escaping"
- unix-error)
- (register-reply! 451
- (format #f "Unix error: ~A." unix-error))
- (escape 'fick-dich-ins-knie)))
- (lambda ()
- (dispatch-command command arg))))))))
-
-(define (dispatch-command command arg)
-; (log (syslog-level debug)
-; "dispatching command ~S with argument ~S"
-; command arg)
- (cond
- ((assoc command *command-alist*)
- => (lambda (pair)
- (log (syslog-level debug)
- "command ~S was found in command-list and is executed with argument ~S"
- (car pair) arg)
- ((cdr pair) arg)))
- (else
- (log (syslog-level debug) "rejecting unknown command ~S (500) (argument: ~S)"
- command arg)
- (register-reply! 500
- (string-append
- (format #f "Unknown command: \"~A\"" command)
- (if (string=? "" arg)
- "."
- (format #f " (argument(s) \"~A\")." arg)))))))
-
-
-(define (handle-user name)
- (log-command (syslog-level info) "USER" name)
- (cond
- ((the-session-logged-in?)
- (log (syslog-level info) "user ~S is already logged in (230)"
- name)
- (register-reply! 230
- "You are already logged in."))
- ((or (string=? "anonymous" name)
- (string=? "ftp" name))
- (handle-user-anonymous))
- (else
- (log (syslog-level info) "rejecting non-anonymous login (530)")
- (register-reply! 530
- "Only anonymous logins allowed."))))
-
-(define (handle-user-anonymous)
- (log (syslog-level info) "anonymous user login (230)")
- (set-the-session-logged-in?! #t)
- (set-the-session-authenticated?! #t)
- (set-the-session-anonymous?! #t)
- (set-the-session-root-directory!
- (file-name-as-directory (the-ftpd-options-anonymous-home)))
- (set-the-session-current-directory! "")
-
- (register-reply! 230 "Anonymous user logged in."))
-
-(define (handle-pass password)
- (log-command (syslog-level info) "PASS" password)
- (cond
- ((not (the-session-logged-in?))
- (log (syslog-level info) "Rejecting password; user has not logged in yet. (530)")
- (register-reply! 530 "You have not logged in yet."))
- ((the-session-anonymous?)
- (log (syslog-level info) "Accepting password; user is logged in (200)")
- (register-reply! 200 "Thank you."))
- (else
- (log (syslog-level notice) "Reached unreachable case-branch while handling password (502)")
- (register-reply! 502 "This can't happen."))))
-
-(define (handle-quit foo)
- (log-command (syslog-level info) "QUIT")
- (log (syslog-level debug) "quitting (221)")
- (register-reply! 221 "Goodbye! Au revoir! Auf Wiedersehen!")
- (signal 'ftpd-quit))
-
-(define (handle-syst foo)
- (log-command (syslog-level info) "SYST")
- (log (syslog-level debug) "telling system type (215)")
- (register-reply! 215 "UNIX Type: L8"))
-
-(define (handle-cwd path)
- (log-command (syslog-level info) "CWD" path)
- (ensure-authenticated-login)
- (let ((current-directory (assemble-path (the-session-current-directory)
- path)))
- (with-errno-handler*
- (lambda (errno packet)
- (let ((error-reason (car packet)))
- (log (syslog-level info)
- "can't change to directory \"~A\": ~A (550)"
- path error-reason)
- (signal-error! 550
- (format #f "Can't change directory to \"~A\": ~A."
- path
- error-reason))))
- (lambda ()
- (with-cwd*
- (file-name-as-directory
- (string-append (the-session-root-directory) current-directory))
- (lambda () ; I hate gratuitous syntax
- (log (syslog-level debug)
- "changing current directory to \"/~A\" (250)"
- current-directory)
- (set-the-session-current-directory! current-directory)
- (register-reply! 250
- (format #f "Current directory changed to \"/~A\"."
- current-directory))))))))
-
-(define (handle-cdup foo)
- (log-command (syslog-level info) "CDUP")
- (handle-cwd ".."))
-
-(define (handle-pwd foo)
- (log-command (syslog-level info) "PWD")
- (ensure-authenticated-login)
- (let ((current-directory (the-session-current-directory)))
- (log (syslog-level info) "replying \"/~A\" as current directory (257)"
- current-directory)
- (register-reply! 257
- (format #f "Current directory is \"/~A\"."
- current-directory))))
-
-
-(define (make-file-action-handler error-format-string action)
- (lambda (path)
- (ensure-authenticated-login)
- (if (string=? "" path)
- (begin
- (log (syslog-level info)
- "finishing processing command because of missing arguments (500)")
- (signal-error! 500 "No argument.")))
- (let ((full-path (string-append (the-session-root-directory)
- (assemble-path (the-session-current-directory)
- path))))
- (with-errno-handler*
- (lambda (errno packet)
- (let ((error-reason (car packet)))
- (log (syslog-level info)
- (string-append error-format-string " (550)") path error-reason)
- (signal-error! 550
- (format #f error-format-string
- path error-reason))))
- (lambda ()
- (action path full-path))))))
-
-(define handle-dele
- (make-file-action-handler
- "Could not delete \"~A\": ~A."
- (lambda (path full-path)
- (log-command (syslog-level info) "DELE" path)
- (delete-file full-path)
- (log (syslog-level debug) "deleted ~S (250)" full-path)
- (log (syslog-level debug) "reporting about ~S" path)
- (register-reply! 250 (format #f "Deleted \"~A\"." path)))))
-
-(define handle-mdtm
- (make-file-action-handler
- "Could not get info on \"~A\": ~A."
- (lambda (path full-path)
- (log-command (syslog-level info) "MDTM" path)
- (let* ((info (file-info full-path))
- (the-date (date (file-info:mtime info) 0))
- (formatted-date (format-date "~Y~m~d~H~M~S" the-date)))
- (log (syslog-level debug) "reporting modification time of ~S: ~A (213)"
- full-path
- formatted-date)
- (register-reply! 213
- formatted-date)))))
-
-(define handle-mkd
- (make-file-action-handler
- "Could not make directory \"~A\": ~A."
- (lambda (path full-path)
- (log-command (syslog-level info) "MKD" path)
- (create-directory full-path #o755)
- (log (syslog-level debug) "created directory ~S (257)" full-path)
- (log (syslog-level debug) "reporting about ~S" path)
- (register-reply! 257
- (format #f "Created directory \"~A\"." path)))))
-
-(define handle-rmd
- (make-file-action-handler
- "Could not remove directory \"~A\": ~A."
- (lambda (path full-path)
- (log-command (syslog-level info) "RMD" path)
- (delete-directory full-path)
- (log (syslog-level debug) "deleted directory ~S (250)" full-path)
- (log (syslog-level debug) "reporting about ~S" path)
- (register-reply! 250
- (format #f "Deleted directory \"~A\"." path)))))
-
-
-(define handle-rnfr
- (make-file-action-handler
- "Could not get info on file \"~A\": ~A."
- (lambda (path full-path)
- (log-command (syslog-level info) "RNFR" path)
- (file-info full-path)
- (log (syslog-level debug)
- "RNFR-command accepted, waiting for RNTO-command (350)")
- (register-reply! 350 "RNFR accepted. Gimme a RNTO next.")
- (set-the-session-to-be-renamed! full-path))))
-
-(define (handle-rnto path)
- (log-command (syslog-level info) "RNTO" path)
- (ensure-authenticated-login)
- (if (not (the-session-to-be-renamed))
- (begin
- (log (syslog-level info)
- "RNTO-command rejected: need RNFR-command before (503)")
- (signal-error! 503 "Need RNFR before RNTO.")))
- (if (string=? "" path)
- (begin
- (log (syslog-level info)
- "No argument -- still waiting for (correct) RNTO-command (500)")
- (signal-error! 500 "No argument.")))
- (let ((full-path (string-append (the-session-root-directory)
- (assemble-path (the-session-current-directory)
- path))))
-
- (if (file-exists? full-path)
- (begin
- (log (syslog-level info) "rename of ~S failed (already exists) (550)"
- full-path)
- (log (syslog-level debug) "reporting about ~S"
- path)
- (signal-error!
- 550
- (format #f "Rename failed---\"~A\" already exists or is protected."
- path))))
-
- (with-errno-handler*
- (lambda (errno packet)
- (log (syslog-level info)
- "failed to rename ~A (550)" path)
- (signal-error! 550
- (format #f "Could not rename: ~A." path)))
- (lambda ()
- (let ((old-name (the-session-to-be-renamed)))
- (rename-file old-name full-path)
- (log (syslog-level debug)
- "~S renamed to ~S - no more waiting for RNTO-command (250)"
- old-name full-path)
- (register-reply! 250 "File renamed.")
- (set-the-session-to-be-renamed! #f))))))
-
-(define handle-size
- (make-file-action-handler
- "Could not get info on file \"~A\": ~A."
- (lambda (path full-path)
- (log-command (syslog-level info) "SIZE" path)
- (let ((info (file-info full-path)))
- (if (not (eq? 'regular (file-info:type info)))
- (begin
- (log (syslog-level info)
- "rejecting SIZE-command as ~S is not a regular file (550)"
- full-path)
- (log (syslog-level debug) "reporting about ~S" path)
- (signal-error! 550
- (format #f "\"~A\" is not a regular file."
- path))))
- (let ((file-size (file-info:size info)))
- (log (syslog-level debug)
- "reporting ~D as size of ~S (213)"
- file-size full-path)
- (register-reply! 213 (number->string file-size)))))))
-
-
-(define (handle-type arg)
- (log-command (syslog-level info) "TYPE" arg)
- (cond
- ((string-ci=? "A" arg)
- (log (syslog-level debug) "changed type to ascii (200)")
- (set-the-session-type! 'ascii))
- ((string-ci=? "I" arg)
- (log (syslog-level debug) "changed type to image (8-bit binary) (200)")
- (set-the-session-type! 'image))
- ((string-ci=? "L8" arg)
- (log (syslog-level debug) "changed type to image (8-bit binary) (200)")
- (set-the-session-type! 'image))
- (else
- (log (syslog-level info)
- "rejecting TYPE-command: unknown type (504)")
- (signal-error! 504
- (format #f "Unknown TYPE: ~S." arg))))
-
- (log (syslog-level debug) "reporting new type (see above)")
- (register-reply! 200
- (format #f "TYPE is now ~A."
- (case (the-session-type)
- ((ascii) "ASCII")
- ((image) "8-bit binary")
- (else "somethin' weird, man")))))
-
-(define (handle-mode arg)
- (log-command (syslog-level info) "MODE" arg)
- (cond
- ((string=? "" arg)
- (log (syslog-level info) "rejecting MODE-command: no arguments (500)")
- (register-reply! 500
- "No arguments. Not to worry---I'd ignore them anyway."))
- ((string-ci=? "S" arg)
- (log (syslog-level info)
- "stream mode is (still) used for file-transfer (200)")
- (register-reply! 200 "Using stream mode to transfer files."))
- (else
- (log (syslog-level info) "mode ~S is not supported (504)" arg)
- (register-reply! 504 (format #f "Mode \"~A\" is not supported."
- arg)))))
-
-(define (handle-stru arg)
- (log-command (syslog-level info) "STRU" arg)
- (cond
- ((string=? "" arg)
- (log (syslog-level info) "rejecting STRU-command: no arguments (500)")
- (register-reply! 500
- "No arguments. Not to worry---I'd ignore them anyway."))
- ((string-ci=? "F" arg)
- (log (syslog-level debug) "(still) using file structure to transfer files (200)")
- (register-reply! 200 "Using file structure to transfer files."))
- (else
- (log (syslog-level info) "file structure ~S is not supported (504)" arg)
- (register-reply! 504
- (format #f "File structure \"~A\" is not supported."
- arg)))))
-
-(define (handle-noop arg)
- (log-command (syslog-level info) "NOOP")
- (log (syslog-level debug) "successfully done nothing (200)")
- (register-reply! 200 "Done nothing, but successfully."))
-
-(define (ftpd-parse-port-arg stuff)
- (with-fatal-error-handler*
- (lambda (condition more)
- (log (syslog-level debug) "reporting syntax error in argument (500)")
- (signal-error! 500
- "Syntax error in argument to PORT."))
- (lambda ()
- (parse-port-arg stuff))))
-
-(define (handle-port stuff)
- (log-command (syslog-level info) "PORT" stuff)
- (ensure-authenticated-login)
- (maybe-close-data-connection)
- (call-with-values
- (lambda () (ftpd-parse-port-arg stuff))
- (lambda (address port)
- (let ((socket (create-socket protocol-family/internet
- socket-type/stream)))
- (log (syslog-level debug)
- "created new socket (internet, stream, reusing address)")
- (set-socket-option socket level/socket socket/reuse-address #t)
-
- (connect-socket socket
- (internet-address->socket-address
- address port))
-
- (set-the-session-data-socket! socket)
-
- (let ((formatted-internet-host-address
- (format-internet-host-address address)))
- (log (syslog-level debug)
- "connected to ~A, port ~A (200)"
- formatted-internet-host-address port)
-
- (register-reply! 200
- (format #f "Connected to ~A, port ~A."
- formatted-internet-host-address
- port)))))))
-
-
-(define (handle-pasv stuff)
- (log-command (syslog-level info) "PASV")
- (ensure-authenticated-login)
- (maybe-close-data-connection)
- (let ((socket (create-socket protocol-family/internet
- socket-type/stream)))
-
- (set-socket-option socket level/socket socket/reuse-address #t)
-
- (bind-socket socket
- (internet-address->socket-address (this-host-address)
- 0))
- (listen-socket socket 1)
-
- (let ((address (socket-local-address socket)))
-
- (call-with-values
- (lambda () (socket-address->internet-address address))
- (lambda (host-address port)
-
- (set-the-session-passive-socket! socket)
-
-
- (let ((formatted-this-host-address
- (format-internet-host-address (this-host-address) ","))
- (formatted-port (format-port port)))
- (log (syslog-level debug) "accepting passive mode (on ~A,~A) (227)"
- formatted-this-host-address formatted-port)
- (register-reply! 227
- (format #f "Passive mode OK (~A,~A)"
- formatted-this-host-address
- formatted-port))))))))
-
-(define (this-host-address)
- (let ((socket (port->socket (the-session-control-input-port)
- protocol-family/internet)))
- (call-with-values
- (lambda ()
- (socket-address->internet-address
- (socket-local-address socket)))
- (lambda (host-address control-port)
- (log (syslog-level debug) "Closing ~A ~A"
- (socket:inport socket) (socket:outport socket))
- (close-socket socket)
- host-address))))
-
-(define (handle-nlst arg)
- (log-command (syslog-level info) "NLST" arg)
- (handle-listing arg '()))
-
-(define (handle-list arg)
- (log-command (syslog-level info) "LIST" arg)
- (handle-listing arg '(long)))
-
-(define (handle-listing arg preset-flags)
- (ensure-authenticated-login)
- (with-data-connection
- (lambda ()
- (let ((args (split-arguments arg)))
- (call-with-values
- (lambda ()
- (partition
- (lambda (arg)
- (and (not (string=? "" arg))
- (char=? #\- (string-ref arg 0))))
- args))
- (lambda (flag-args rest-args)
-
- (if (and (not (null? rest-args))
- (not (null? (cdr rest-args))))
- (begin
- (log (syslog-level info) "got more than one path argument - rejection (501)")
- (signal-error! 501 "More than one path argument.")))
-
- (let ((path (if (null? rest-args)
- ""
- (car rest-args)))
- (flags (arguments->ls-flags flag-args)))
-
- (if (not flags)
- (begin
- (log (syslog-level info) "got invalid flags (501)")
- (signal-error! 501 "Invalid flag(s).")))
- (let ((all-flags (append preset-flags flags)))
- (log (syslog-level debug)
- "sending file-listing for path ~S with flags ~A"
- path all-flags)
-
- (generate-listing path all-flags)))))))))
-
-; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or
-; ENSURE-DATA-CONNECTION.
-
-(define (generate-listing path flags)
- (let ((full-path (string-append (the-session-root-directory)
- (assemble-path (the-session-current-directory)
- path))))
- (with-errno-handler*
- (lambda (errno packet)
- (let ((error-reason (car packet)))
- (log (syslog-level info)
- "can't access directory at ~A: ~A (451)"
- path error-reason)
- (signal-error! 451
- (format #f "Can't access directory at ~A: ~A."
- path
- error-reason))))
- (lambda ()
- (with-cwd*
- (file-name-directory full-path)
- (lambda ()
- (let ((nondir (file-name-nondirectory full-path)))
- (let-fluid
- ls-crlf? #t
- (lambda ()
- (ls flags
- (list
- ;; work around OLIN BUG
- (if (string=? nondir "")
- "."
- nondir))
- (socket:outport (the-session-data-socket))))))))))))
-
-(define (handle-abor foo)
- (log-command (syslog-level info) "ABOR")
- (maybe-close-data-connection)
- (log (syslog-level debug) "closing data connection (226)")
- (register-reply! 226 "Closing data connection."))
-
-(define (handle-retr path)
- (log-command (syslog-level info) "RETR" path)
- (ensure-authenticated-login)
- (let ((full-path (string-append (the-session-root-directory)
- (assemble-path (the-session-current-directory)
- path))))
- (with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO
- (lambda (condition more)
- (let ((reason (condition-stuff condition)))
- (log (syslog-level info) "failed to open ~S for reading (maybe reason: ~S) (550)" full-path reason)
- (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason)
- (signal-error! 550
- (format #f "Can't open \"~A\" for reading."
- path))))
- (lambda ()
- (let ((info (file-info full-path))
- (start-transfer-seconds (current-seconds)))
- (if (not (eq? 'regular (file-info:type info)))
- (begin
- (log (syslog-level info) "rejecting RETR-command as ~S is not a regular file (450)"
- full-path)
- (log (syslog-level debug) "reporting about ~S" path)
- (signal-error! 450
- (format #f "\"~A\" is not a regular file."
- path))))
- (call-with-input-file full-path
- (lambda (file-port)
- (with-data-connection
- (lambda ()
- (case (the-session-type)
- ((image)
- (log (syslog-level debug)
- "sending file ~S (binary mode)"
- full-path)
- (log (syslog-level debug) "sending is from port ~S" file-port)
- (copy-port->port-binary
- file-port
- (socket:outport (the-session-data-socket))))
- ((ascii)
- (log (syslog-level debug) "sending file ~S (ascii mode)"
- full-path)
- (log (syslog-level debug) "sending is from port ~S" file-port)
- (copy-port->port-ascii
- file-port
- (socket:outport (the-session-data-socket)))))
- (file-log start-transfer-seconds info full-path "o"))))))))))
-
-(define (current-seconds)
- (receive (time ticks) (time+ticks) time))
-
-(define (handle-stor path)
- (log-command (syslog-level info) "STOR" path)
- (ensure-authenticated-login)
- (let ((full-path (string-append (the-session-root-directory)
- (assemble-path (the-session-current-directory)
- path))))
- (with-fatal-error-handler*
- (lambda (condition more)
- (let ((reason (condition-stuff condition)))
- (log (syslog-level info) "can't open ~S for writing (maybe reason: ~S) (550)" full-path reason)
- (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason)
- (signal-error! 550 (format #f "Can't open \"~A\" for writing." path))))
- (lambda ()
- (let ((start-transfer-seconds (current-seconds)))
- (call-with-output-file full-path
- (lambda (file-port)
- (with-data-connection
- (lambda ()
- (let ((inport (socket:inport (the-session-data-socket))))
- (case (the-session-type)
- ((image)
- (log (syslog-level notice)
- "storing data to ~S (binary mode)"
- full-path)
- (log (syslog-level debug)
- "storing comes from socket-inport ~S (binary-mode)"
- inport)
- (copy-port->port-binary
- (socket:inport (the-session-data-socket))
- file-port))
- ((ascii)
- (log (syslog-level notice)
- "storing data to ~S (ascii-mode)"
- full-path)
- (log (syslog-level debug)
- "storing comes from socket-inport ~S (ascii-mode)"
- inport)
- (copy-ascii-port->port
- (socket:inport (the-session-data-socket))
- file-port)))
- (file-log start-transfer-seconds (file-info full-path) full-path "i")
- ))))))))))
-
-(define (assemble-path current-directory path)
- (log (syslog-level debug) "assembling path ~S"
- path)
- (let* ((interim-path
- (if (not (file-name-rooted? path))
- (string-append (file-name-as-directory current-directory)
- path)
- path))
- (complete-path (if (file-name-rooted? interim-path)
- (file-name-sans-rooted interim-path)
- interim-path)))
- (log (syslog-level debug) "name ~S assembled to ~S"
- path complete-path)
- (cond
- ((normalize-path complete-path)
- => (lambda (assembled-path) assembled-path))
- (else
- (log (syslog-level debug)
- "invalid pathname -- tried to pass root directory (501)")
- (signal-error! 501 "Invalid pathname")))))
-
-(define (ensure-authenticated-login)
- (if (or (not (the-session-logged-in?))
- (not (the-session-authenticated?)))
- (begin
- (log (syslog-level debug)
- "login authentication failed - user is not logged in (530)")
- (signal-error! 530 "You're not logged in yet."))
- (log (syslog-level debug) "authenticated login ensured")))
-
-(define (with-data-connection thunk)
- (dynamic-wind ensure-data-connection
- thunk
- maybe-close-data-connection))
-
-(define *window-size* 4096)
-
-(define (ensure-data-connection)
- (if (and (not (the-session-data-socket))
- (not (the-session-passive-socket)))
- (begin
- (log (syslog-level debug) "no data connection (425)")
- (signal-error! 425 "No data connection.")))
-
- (if (the-session-passive-socket)
- (call-with-values
- (lambda () (accept-connection (the-session-passive-socket)))
- (lambda (socket socket-address)
- (set-the-session-data-socket! socket))))
-
- (log (syslog-level debug) "opening data connection (150)")
- (register-reply! 150 "Opening data connection.")
- (write-replies)
-
- (set-socket-option (the-session-data-socket) level/socket
- socket/send-buffer *window-size*)
- (set-socket-option (the-session-data-socket) level/socket
- socket/receive-buffer *window-size*))
-
-(define (maybe-close-data-connection)
- (if (or (the-session-data-socket) (the-session-passive-socket))
- (close-data-connection)))
-
-(define (close-data-connection)
- (if (the-session-data-socket)
- (close-socket (the-session-data-socket)))
- (if (the-session-passive-socket)
- (close-socket (the-session-passive-socket)))
- (log (syslog-level debug) "closing data connection (226)")
- (register-reply! 226 "Closing data connection.")
- (set-the-session-data-socket! #f)
- (set-the-session-passive-socket! #f))
-
-(define *command-alist*
- (list
- (cons "NOOP" handle-noop)
- (cons "USER" handle-user)
- (cons "PASS" handle-pass)
- (cons "QUIT" handle-quit)
- (cons "SYST" handle-syst)
- (cons "CWD" handle-cwd)
- (cons "PWD" handle-pwd)
- (cons "CDUP" handle-cdup)
- (cons "DELE" handle-dele)
- (cons "MDTM" handle-mdtm)
- (cons "MKD" handle-mkd)
- (cons "RMD" handle-rmd)
- (cons "RNFR" handle-rnfr)
- (cons "RNTO" handle-rnto)
- (cons "SIZE" handle-size)
- (cons "TYPE" handle-type)
- (cons "MODE" handle-mode)
- (cons "STRU" handle-stru)
- (cons "PORT" handle-port)
- (cons "PASV" handle-pasv)
- (cons "NLST" handle-nlst)
- (cons "LIST" handle-list)
- (cons "RETR" handle-retr)
- (cons "STOR" handle-stor)
- (cons "ABOR" handle-abor)))
-
-(define (parse-command-line line)
- (if (eof-object? line) ; Netscape does this
- (signal 'ftpd-irregular-quit)
- (let* ((line (string-trim-both line char-set:whitespace))
- (split-position (string-index line #\space)))
- (if split-position
- (values (string-map char-upcase (substring line 0 split-position))
- (string-trim-both (substring line
- (+ 1 split-position)
- (string-length line))
- char-set:whitespace))
- (values (string-map char-upcase line) "")))))
-
-; Path names
-
-; This removes all internal ..'s from a path.
-; NORMALIZE-PATH returns #f if PATH points to a parent directory.
-
-(define (normalize-path path)
- (let loop ((components (split-file-name (simplify-file-name path)))
- (reverse-result '()))
- (cond
- ((null? components)
- (path-list->file-name (reverse reverse-result)))
- ((string=? ".." (car components))
- (if (null? reverse-result)
- #f
- (loop (cdr components) (cdr reverse-result))))
- (else
- (loop (cdr components) (cons (car components) reverse-result))))))
-
-(define (file-name-rooted? file-name)
- (and (not (string=? "" file-name))
- (char=? #\/ (string-ref file-name 0))))
-
-(define (file-name-sans-rooted file-name)
- (substring file-name 1 (string-length file-name)))
-
-(define split-arguments
- (infix-splitter (make-regexp " +")))
-
-; Reply handling
-
-; Replies must be synchronous with requests and actions. Therefore,
-; they are queued on generation via REGISTER-REPLY!. The messages are
-; printed via WRITE-REPLIES. For the nature of the replies, see RFC
-; 959.
-
-
-(define (write-replies)
- (if (not (null? (the-session-reverse-replies)))
- (let loop ((messages (reverse (the-session-reverse-replies))))
- (if (null? (cdr messages))
- (write-final-reply (car messages))
- (begin
- (write-nonfinal-reply (car messages))
- (loop (cdr messages))))))
- (set-the-session-reverse-replies! '()))
-
-(define (write-final-reply line)
- (format (the-session-control-output-port) "~D ~A" (the-session-reply-code) line)
- (log (syslog-level debug) "Reply: ~D ~A~%" (the-session-reply-code) line)
- (write-crlf (the-session-control-output-port))
- (force-output (the-session-control-output-port)))
-
-(define (write-nonfinal-reply line)
- (format (the-session-control-output-port) "~D-~A" (the-session-reply-code) line)
- (log (syslog-level debug) "Reply: ~D-~A~%" (the-session-reply-code) line)
- (write-crlf (the-session-control-output-port)))
-
-(define (signal-error! code message)
- (register-reply! code message)
- (signal 'ftpd-error))
-
-(define (register-reply! code message)
- (set-the-session-reverse-replies!
- (cons message (the-session-reverse-replies)))
- (set-the-session-reply-code! code))
-
diff --git a/scheme/httpd/access-control.scm b/scheme/httpd/access-control.scm
deleted file mode 100644
index 9e83fa5..0000000
--- a/scheme/httpd/access-control.scm
+++ /dev/null
@@ -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.
-;;; 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)))))
\ No newline at end of file
diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm
deleted file mode 100644
index 37516b0..0000000
--- a/scheme/httpd/cgi-server.scm
+++ /dev/null
@@ -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 and 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 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
-;;; ? part of the URI. (Hence the CGI script will split the individual
-;;; fields into argv[].)
-
-
-;;; CGI interface:
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; - The URL's 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
diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm
deleted file mode 100644
index d942b35..0000000
--- a/scheme/httpd/core.scm
+++ /dev/null
@@ -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 # 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))
-
diff --git a/scheme/httpd/error.scm b/scheme/httpd/error.scm
deleted file mode 100644
index fcb6dde..0000000
--- a/scheme/httpd/error.scm
+++ /dev/null
@@ -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))
-
diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm
deleted file mode 100644
index 4e6f22e..0000000
--- a/scheme/httpd/file-dir-handler.scm
+++ /dev/null
@@ -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 ( . ),
-;;; serving
-;;; ~//
-
-(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 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 "")))
- (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))))
-
diff --git a/scheme/httpd/handlers.scm b/scheme/httpd/handlers.scm
deleted file mode 100644
index 81bdeaa..0000000
--- a/scheme/httpd/handlers.scm
+++ /dev/null
@@ -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))
diff --git a/scheme/httpd/http-top.scm b/scheme/httpd/http-top.scm
deleted file mode 100644
index 908f064..0000000
--- a/scheme/httpd/http-top.scm
+++ /dev/null
@@ -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// => serve 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/ passes control to script
-;;; /usr/local/etc/httpd/cgi-bin/
-;;; - 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")))
-
diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm
deleted file mode 100644
index 18a49ff..0000000
--- a/scheme/httpd/info-gateway.scm
+++ /dev/null
@@ -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 (), 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?.
-;;;
-;;; 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)))))))))
diff --git a/scheme/httpd/logging.scm b/scheme/httpd/logging.scm
deleted file mode 100644
index ea6a48f..0000000
--- a/scheme/httpd/logging.scm
+++ /dev/null
@@ -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))
\ No newline at end of file
diff --git a/scheme/httpd/options.scm b/scheme/httpd/options.scm
deleted file mode 100644
index 24ec38a..0000000
--- a/scheme/httpd/options.scm
+++ /dev/null
@@ -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))))))
diff --git a/scheme/httpd/request.scm b/scheme/httpd/request.scm
deleted file mode 100644
index 303724f..0000000
--- a/scheme/httpd/request.scm
+++ /dev/null
@@ -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))))
-
diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm
deleted file mode 100644
index 79cd524..0000000
--- a/scheme/httpd/response.scm
+++ /dev/null
@@ -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 "
~%Further Information: ~A
~%" message))))
- (close-html (lambda (port)
- (for-each (lambda (x) (format port "
~s~%" x)) extras)
- (write-string "