Compare commits
1 Commits
main
...
surflet-se
| Author | SHA1 | Date |
|---|---|---|
cvs-fast-export
|
e1ec98d90b |
.gitignoreCOPYINGINSTALLMakefileREADMERELEASE
doc
.gitignore
pkg-def.scmhtml
latex
.gitignore.tex2page.hdirMakefilecgi-script.texcode.stycss.t2pct.stydecls.texdns.texftp.texftpd.texheadings.styhttpd.texintro.texman.hdirman.t2pman.texmantitle.stymatter.stymysize10.stynetrc.texnettime.texpdfcond.texpop3.texrfc822.texskeleton.texsmtp.texsurfletapi.texsurflethowto.texsurflets.texuri.texurl.tex
scheme
dnsd
READMEcache.scmdatabase.scmdb-options.scmdnsd.scm
etc
logging.scmmasterfile-parser.scmmasterfile.lmasterfile.l.scmoptions.scmresolver.scmrr-def.scmrw-locks.scmsemaphores.scmslist.scmftpd
httpd
access-control.scmcgi-server.scmcore.scmerror.scmfile-dir-handler.scmhandlers.scminfo-gateway.scmlogging.scmoptions.scmrequest.scmresponse.scmrman-gateway.scmserver.scmseval.scm
surflets
.gitignoreSSAX-goodhtml-patchTODOaddresses.scmbindings.scmcallbacks.scmhandle-fatal.scmids.scminput-fields.scm
latex
load-surflet-server.scmoutdater.scmpackages.scmreturned-via.scmrt-module.scmsend-html.scmsend-xml.scmsimple-surflet-api.scmstart-surflet-serversurflet-handler.scmsurflet-input-fields.scmsurflet-request.scmsurflet-response.scm|
|
@ -1,31 +0,0 @@
|
|||
# CVS default ignores begin
|
||||
tags
|
||||
TAGS
|
||||
.make.state
|
||||
.nse_depinfo
|
||||
*~
|
||||
\#*
|
||||
.#*
|
||||
,*
|
||||
_$*
|
||||
*$
|
||||
*.old
|
||||
*.bak
|
||||
*.BAK
|
||||
*.orig
|
||||
*.rej
|
||||
.del-*
|
||||
*.a
|
||||
*.olb
|
||||
*.o
|
||||
*.obj
|
||||
*.so
|
||||
*.exe
|
||||
*.Z
|
||||
*.elc
|
||||
*.ln
|
||||
core
|
||||
# CVS default ignores end
|
||||
test-packages.scm
|
||||
test
|
||||
SSAX
|
||||
28
COPYING
28
COPYING
|
|
@ -1,28 +0,0 @@
|
|||
Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
|
||||
Copyright (c) 1996-2004 by Mike Sperber.
|
||||
Copyright (c) 1999-2004 by Martin Gasbichler.
|
||||
Copyright (c) 1998-2004 by Eric Marsden.
|
||||
Copyright (c) 2001-2004 by Andreas Bernauer
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions
|
||||
are met:
|
||||
1. Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
2. Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in the
|
||||
documentation and/or other materials provided with the distribution.
|
||||
3. The name of the authors may not be used to endorse or promote products
|
||||
derived from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
48
INSTALL
48
INSTALL
|
|
@ -1,48 +0,0 @@
|
|||
These are generic installation instructions for scsh packages.
|
||||
|
||||
Prerequisites
|
||||
=============
|
||||
|
||||
The scsh installation library is required to install this package.
|
||||
This library *must* be present on your system before the current
|
||||
package can be installed. It can be obtained from the following Web
|
||||
page:
|
||||
|
||||
http://lamp.epfl.ch/~schinz/scsh_packages/
|
||||
|
||||
The installation library comes with its own documentation which
|
||||
explains in detail how to install and use scsh packages. It is
|
||||
recommended that you read it before installing your first scsh
|
||||
package. What follows is a very brief summary of this documentation,
|
||||
intended to get you started quickly.
|
||||
|
||||
In addition, you need to have the Sunterlib library installed. See
|
||||
|
||||
http://www.scsh.net/resources/sunterlib.html
|
||||
|
||||
for more information about obtaining and installing Sunterlib.
|
||||
|
||||
Installation
|
||||
============
|
||||
|
||||
Installation of a scsh package is performed by launching the
|
||||
"scsh-install-pkg" script, which is part of the scsh installation
|
||||
library. This script must be launched from within the directory which
|
||||
resulted from the expansion of the current package's archive, i.e. the
|
||||
one containing the file you are reading now.
|
||||
|
||||
A list of all the arguments accepted by the "scsh-install-pkg" script
|
||||
can be obtained by launching it with the "--help" option. One of these
|
||||
arguments, "--prefix", is mandatory and specifies the location where
|
||||
installation should be performed. Ideally, you should use the same
|
||||
prefix to install all scsh packages, as this makes them easier to
|
||||
manage and use.
|
||||
|
||||
For example, to install the current package in
|
||||
"/usr/local/share/scsh-modules", you should type the following:
|
||||
|
||||
scsh-install-pkg --prefix=/usr/local/share/scsh-modules
|
||||
|
||||
Provided that no errors are encountered during installation, a
|
||||
message will be printed at the end explaining how to use the newly
|
||||
installed package.
|
||||
51
Makefile
51
Makefile
|
|
@ -1,51 +0,0 @@
|
|||
SHELL = /bin/sh
|
||||
|
||||
version_id = 2.1
|
||||
|
||||
distname = sunet-$(version_id)
|
||||
|
||||
distdir = /tmp
|
||||
|
||||
DISTFILES = COPYING README RELEASE INSTALL pkg-def.scm \
|
||||
scheme/packages.scm \
|
||||
scheme/httpd/*.scm scheme/httpd/surflets/*.scm \
|
||||
scheme/ftpd/*.scm scheme/lib/*.scm \
|
||||
doc/pdf/sunet.pdf doc/html \
|
||||
doc/latex/*.tex doc/latex/*.sty doc/latex/*.t2p doc/latex/*.hdir \
|
||||
web-server
|
||||
|
||||
sunet-$(version_id).tar.gz:
|
||||
|
||||
.PHONY: dist
|
||||
|
||||
dist:
|
||||
cd doc/latex && $(MAKE) html
|
||||
cd doc/latex && $(MAKE) man.pdf
|
||||
cd web-server/root/htdocs
|
||||
mkdir -p doc/pdf
|
||||
cp doc/latex/man.pdf doc/pdf/sunet.pdf
|
||||
mv doc/html/man.html doc/html/index.html
|
||||
distname=$(distname) && \
|
||||
distfile=$(distdir)/$$distname.tar.gz && \
|
||||
if [ -d $(distdir) ] && \
|
||||
[ -w $$distfile -o -w $(distdir) ]; then \
|
||||
rm -f $$distname && \
|
||||
ln -s . $$distname && \
|
||||
files='' && \
|
||||
for i in $(DISTFILES); do \
|
||||
if [ "$$i" != "c/sysdep.h" ]; then \
|
||||
files="$$files $$distname/$$i"; \
|
||||
fi \
|
||||
done && \
|
||||
tar --exclude .cvsignore --exclude CVS -cf - $$files | \
|
||||
gzip --best >$$distfile && \
|
||||
rm $$distname; \
|
||||
else \
|
||||
echo "Can't write $$distfile" >&2; \
|
||||
exit 1; \
|
||||
fi
|
||||
|
||||
|
||||
.PHONY: tags
|
||||
tags:
|
||||
find . -name "*.scm" | etags -
|
||||
118
README
118
README
|
|
@ -1,118 +0,0 @@
|
|||
This is the Scheme Untergrund Networking Package.
|
||||
|
||||
The Scheme Untergrund Networking Package (SUnet, for short) is a
|
||||
collection of applications and libraries for Internet hacking in
|
||||
Scheme. It contains over 15000 lines of high-quality Scheme code that
|
||||
runs under Scsh, the Scheme shell. SUnet makes extensive use of
|
||||
Scsh's facilities for multi-threaded systems programming on Unix.
|
||||
|
||||
SUnet includes the following components:
|
||||
|
||||
* The SUnet Web server
|
||||
This is a highly configurable HTTP 1.0 server in Scheme.
|
||||
The server is accompanied some libraries which may also
|
||||
be used separately:
|
||||
|
||||
* URI and URL parsers and unparsers
|
||||
* a library for writing CGI scripts in Scheme
|
||||
* server extensions for interfacing to CGI scripts
|
||||
* server extensions for uploading Scheme code
|
||||
* simple structured HTML output library
|
||||
|
||||
The server also ships with a sophisticated interface for writing
|
||||
server-side Web applications called "SUrflets".
|
||||
|
||||
* The SUnet ftp server
|
||||
This is a complete anonymous ftp server in Scheme.
|
||||
|
||||
* ftp client library
|
||||
This library allows you to access ftp servers programmatically.
|
||||
|
||||
* Netrc library
|
||||
This library parses authentication information contained in ~/.netrc.
|
||||
|
||||
* SMTP client library
|
||||
This library allows you to forge mail from the comfort of your own
|
||||
Scheme process.
|
||||
|
||||
* POP3 client library
|
||||
This library allows you to access your POP3 mailbox from inside Scsh.
|
||||
|
||||
* RFC822 header library
|
||||
This library parses email-style headers.
|
||||
|
||||
* Daytime and Time protocol client libraries
|
||||
These libraries lets you find out what time it is without paying for a
|
||||
Rolex.
|
||||
|
||||
* DNS client library
|
||||
This is a complete, multithreaded DNS library.
|
||||
|
||||
* An ls clone
|
||||
This library displays Unix-style directory listings without running ls.
|
||||
|
||||
Download
|
||||
========
|
||||
|
||||
The SUnet code is available from
|
||||
|
||||
http://www.scsh.net/sunet/
|
||||
|
||||
To run the code, you need version 0.6.4 or later of Scsh, available from
|
||||
|
||||
http://www.scsh.net/
|
||||
|
||||
Installation
|
||||
============
|
||||
|
||||
Starting with version 2.1 SUnet conforms to the packaging proposal for
|
||||
scsh by Michel Schinz and needs Michel's installation library to
|
||||
install properly. For more information, please see:
|
||||
|
||||
<http://lamp.epfl.ch/~schinz/scsh_packages/>
|
||||
|
||||
In short, this means that you can install SUnet by unpacking the SUnet
|
||||
tarball and issuing the following command in the created directory:
|
||||
|
||||
scsh-install-pkg --prefix /path/to/your/package/root
|
||||
|
||||
See the file INSTALL for the generic installation instructions for
|
||||
scsh packages.
|
||||
|
||||
You need to install version 4.9 of the SSAX package to use SUnet. SSAX
|
||||
is available from <http://lamp.epfl.ch/~schinz/scsh_packages/>.
|
||||
|
||||
Sample Web Server
|
||||
=================
|
||||
|
||||
The installation procedure also installs three scripts to run the
|
||||
SUnet httpd in the directory
|
||||
|
||||
/path/to/your/package/root/0.6/sunet/web-server/
|
||||
|
||||
The three scripts are:
|
||||
|
||||
start-web-server for running a simple web server on port 8080
|
||||
start-extended-web-server for running a web server with rman and info gateway
|
||||
start-surflet-server for running a web server with SUrflets enabled
|
||||
|
||||
Pass the --help option to learn how to configure the scripts.
|
||||
|
||||
These scripts should provide a pretty good starting point to set up
|
||||
your own server or serve your own SUrfelts.
|
||||
|
||||
Support
|
||||
=======
|
||||
|
||||
Please direct questions, comments, answers about SUnet to the regular
|
||||
scsh mailing list at
|
||||
|
||||
scsh-users@scsh.net
|
||||
|
||||
Relax, hack, and enjoy!
|
||||
|
||||
Dr. S.
|
||||
Dr. S.
|
||||
Martin Gasbichler
|
||||
Eric Marsden
|
||||
Andreas Bernauer
|
||||
30
RELEASE
30
RELEASE
|
|
@ -1,30 +0,0 @@
|
|||
Scheme Untergrund Networking Library Release Notes
|
||||
==================================================
|
||||
|
||||
We are pleased to release SUnet version 2.1.
|
||||
|
||||
SUnet runs under scsh 0.6.4. It is possible, but unlikely that it
|
||||
runs under earlier versions of scsh. We recommend using version 0.6.6
|
||||
for simple installation using the new packaging proposal. See file
|
||||
INSTALL for more details.
|
||||
|
||||
The major addition of this release are SUrflets by Andreas
|
||||
Bernauer. SUrflets are server-side scripts for the web-server written
|
||||
in Scheme. Based on the idea of Christian Queinnec, SUrflets employ
|
||||
first-class continuations to overcome the lack of state in the HTTP
|
||||
protocol and thereby ease the writing of web applications
|
||||
dramatically. SUrflets represent XHTML using Oleg Kiselyov's SSAX
|
||||
package, which makes it possible to build on the full power of
|
||||
s-expressions for generating XHTML.
|
||||
|
||||
This release also fixes a number of bugs in various parts of the
|
||||
library.
|
||||
|
||||
Relay, hack, and enjoy!
|
||||
|
||||
Dr. S.
|
||||
Dr. S.
|
||||
Martin Gasbichler
|
||||
Eric Marsden
|
||||
Andreas Bernauer
|
||||
|
||||
|
|
@ -1 +0,0 @@
|
|||
pdf
|
||||
|
|
@ -1 +0,0 @@
|
|||
index.html man--h.idx man--h.ilg man--h.ind man.hlog man-Z-A.scm man-Z-H-10.html man-Z-H-11.html man-Z-H-12.html man-Z-H-13.html man-Z-H-14.html man-Z-H-15.html man-Z-H-16.html man-Z-H-17.html man-Z-H-1.html man-Z-H-2.html man-Z-H-3.html man-Z-H-4.html man-Z-H-5.html man-Z-H-6.html man-Z-H-7.html man-Z-H-8.html man-Z-H-9.html man-Z-L.scm man-Z-S.css
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
*.aux
|
||||
*.toc
|
||||
*.dvi
|
||||
*.ps
|
||||
*.pdf
|
||||
*.log
|
||||
*.png
|
||||
*.idx
|
||||
|
|
@ -1 +0,0 @@
|
|||
../../web-server/root/htdocs/sunet-manual
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
.SUFFIXES: .idx .ind .tex .dvi .ps .pdf $(.SUFFIXES)
|
||||
|
||||
TEX= cgi-script.tex ftp.tex pdfcond.tex smtp.tex ftpd.tex pop3.tex \
|
||||
uri.tex decls.tex httpd.tex netrc.tex rfc822.tex url.tex dns.tex \
|
||||
intro.tex nettime.tex skeleton.tex
|
||||
|
||||
TEX2PAGE=tex2page
|
||||
|
||||
man.dvi: $(TEX) man.ind
|
||||
man.ind: man.idx
|
||||
man.pdf: $(TEX) man.ind
|
||||
|
||||
.dvi.ps:
|
||||
dvips -j0 -o $@ $<
|
||||
|
||||
.tex.dvi:
|
||||
latex $< && latex $<
|
||||
rm $*.log
|
||||
|
||||
.tex.pdf:
|
||||
pdflatex $< && thumbpdf $@ && pdflatex $<
|
||||
rm $*.log
|
||||
|
||||
.idx.ind:
|
||||
makeindex $<
|
||||
|
||||
clean:
|
||||
-rm -f *.log *.png man.out man.dvi man.ps man.pdf thumb*.png
|
||||
rm -rf ../../web-server/root/htdocs/sunet-manual
|
||||
|
||||
INSTALL_DATA= install -c -m 644
|
||||
|
||||
tar:
|
||||
tar cf - *.tex sty | gzip > man.tar.gz
|
||||
|
||||
html: $(TEX)
|
||||
$(TEX2PAGE) man && $(TEX2PAGE) man
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
\chapter{Writing CGI Scripts in Scheme}\label{cha:cgi-scripts}
|
||||
%
|
||||
The \ex{cgi-scripts} structure provides functionality useful for
|
||||
writing CGI scripts in Scheme.
|
||||
|
||||
\defun{cgi-form-query}{}{data-alist}
|
||||
\begin{desc}
|
||||
CGI scripts receive their parameters in various ways, depending on
|
||||
how they were called (e.g.\ by \ex{GET} method).
|
||||
|
||||
This procedure translates the delivered form data into an alist of
|
||||
decoded strings, using the environment variables set by the server
|
||||
(\ex{REQUEST\_METHOD}, \ex{QUERY\_STRING} (for a \ex{GET} request),
|
||||
\ex{CONTENT\_LENGTH} (for a \ex{POST} request)). So a query string
|
||||
like \codex{button=on\&\ob{}reply=Oh,\ob{}\%20yes} becomes an alist
|
||||
\codex{(("button" . "on") ("reply" . "Oh, yes"))}
|
||||
|
||||
\ex{Cgi-form-query} only works for \ex{GET} and \ex{POST} methods.
|
||||
\end{desc}
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,296 +0,0 @@
|
|||
% code.sty: -*- latex -*-
|
||||
% Latex macros for a "weak" verbatim mode.
|
||||
% -- like verbatim, except \, {, and } have their usual meanings.
|
||||
|
||||
% Environments: code, tightcode, codeaux, codebox, centercode
|
||||
% Commands: \dcd, \cddollar, \cdmath, \cd, \codeallowbreaks, \codeskip, \^
|
||||
% Already defined in LaTeX, but of some relevance: \#, \$, \%, \&, \_, \{, \}
|
||||
|
||||
% Changelog at the end of the file.
|
||||
|
||||
% These commands give you an environment, code, that is like verbatim
|
||||
% except that you can still insert commands in the middle of the environment:
|
||||
% \begin{code}
|
||||
% for(x=1; x<loop_bound; x++)
|
||||
% y += x^3; /* {\em Add in {\tt x} cubed} */
|
||||
% \end{code}
|
||||
%
|
||||
% All characters are ordinary except \{}. To get \{} in your text,
|
||||
% you use the commands \\, \{, and \}.
|
||||
|
||||
% These macros mess with the definition of the special chars (e.g., ^_~%).
|
||||
% The characters \{} are left alone, so you can still have embedded commands:
|
||||
% \begin{code} f(a,b,\ldots,y,z) \end{code}
|
||||
% However, if your embedded commands use the formerly-special chars, as in
|
||||
% \begin{code} x := x+1 /* \mbox{\em This is $y^3$} */ \end{code}
|
||||
% then you lose. The $ and ^ chars are scanned in as non-specials,
|
||||
% so they don't work. If the chars are scanned *outside* the code env,
|
||||
% then you have no problem:
|
||||
% \def\ycube{$y^3$}
|
||||
% \begin{code} x := x+1 /* {\em This is \ycube} */ \end{code}
|
||||
% If you must put special chars inside the code env, you do it by
|
||||
% prefixing them with the special \dcd ("decode") command, that
|
||||
% reverts the chars to back to special status:
|
||||
% \begin{code} x := x+1 /* {\dcd\em This is $y^3$} */ \end{code}
|
||||
% \dcd's scope is bounded by its enclosing braces. It is only defined within
|
||||
% the code env. You can also turn on just $ with the \cddollar command;
|
||||
% you can turn on just $^_ with the \cdmath command. See below.
|
||||
%
|
||||
% Alternatively, just use \(...\) for $...$, \sp for ^, and \sb for _.
|
||||
|
||||
% WARNING:
|
||||
% Like \verb, you cannot put a \cd{...} inside an argument to a macro
|
||||
% or a command. If you try, for example,
|
||||
% \mbox{\cd{$x^y$}}
|
||||
% you will lose. That is because the text "\cd{$x^y$}" gets read in
|
||||
% as \mbox's argument before the \cd executes. But the \cd has to
|
||||
% have a chance to run before LaTeX ever reads the $x^y$ so it can
|
||||
% turn off the specialness of $ and ^. So, \cd has to appear at
|
||||
% top level, not inside an argument. Similarly, you can't have
|
||||
% a \cd or a \code inside a macro (Although you could use \gdef to
|
||||
% define a macro *inside* a \cd, which you could then use outside.
|
||||
% Don't worry about this if you don't understand it.)
|
||||
|
||||
% BUG: In the codebox env, the effect of a \dcd, \cddollar, or \cdmath
|
||||
% command is reset at the end of each line. This can be hacked by
|
||||
% messing with the \halign's preamble, if you feel up to it.
|
||||
|
||||
% Useage note: the initial newline after the \begin{code} or
|
||||
% \begin{codebox} is eaten, but the last newline is not.
|
||||
% So,
|
||||
% \begin{code}
|
||||
% foo
|
||||
% bar
|
||||
% \end{code}
|
||||
% leaves one more blank line after bar than does
|
||||
% \begin{code}
|
||||
% foo
|
||||
% bar\end{code}
|
||||
% Moral: get in the habit of terminating code envs without a newline
|
||||
% (as in the second example).
|
||||
%
|
||||
|
||||
% All this stuff tweaks the meaning of space, tab, and newline.
|
||||
%===============================================================================
|
||||
% \cd@obeyspaces
|
||||
% Turns all spaces into non-breakable spaces.
|
||||
% Note: this is like \@vobeyspaces except without spurious space in defn.
|
||||
% @xobeysp is basically a space; it's defined in latex.tex.
|
||||
%
|
||||
{\catcode`\ =\active\gdef\cd@obeyspaces{\catcode`\ =\active\let =\@xobeysp}}
|
||||
|
||||
|
||||
|
||||
% \cd@obeytabs
|
||||
% Turns all tabs into 8 non-breakable spaces (which is bogus).
|
||||
%
|
||||
{\catcode`\^^I=\active %
|
||||
\gdef\cd@obeytabs{\catcode`\^^I=\active\let^^I=\cd@tab}}
|
||||
|
||||
\def\cd@tab{\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp}
|
||||
|
||||
|
||||
|
||||
% \cd@obeylines
|
||||
% Turns all cr's into linebreaks. Pagebreaks are not permitted between lines.
|
||||
% This is copied from lplain.tex's \obeylines, with the cr def'n changed.
|
||||
%
|
||||
{\catcode`\^^M=\active % these lines must end with %
|
||||
\gdef\cd@obeylines{\catcode`\^^M=\active\let^^M=\cd@cr}}
|
||||
|
||||
% What ^M turns into. This def'n keeps blank lines from being compressed out.
|
||||
\def\cd@cr{\par\penalty10000\leavevmode} % TeX magicness
|
||||
%\def\cd@cr{\par\penalty10000\mbox{}} % LaTeX
|
||||
|
||||
|
||||
% \codeallowbreaks
|
||||
% Same as \cd@obeylines, except pagebreaks are allowed.
|
||||
% Put this command inside a code env to allow pagebreaks.
|
||||
|
||||
{\catcode`\^^M=\active % these lines must end with %
|
||||
\gdef\codeallowbreaks{\catcode`\^^M\active\let^^M\cd@crbr}}
|
||||
|
||||
%\def\cd@crbr{\leavevmode\endgraf} % What ^M turns into.
|
||||
\def\cd@crbr{\par\leavevmode} % What ^M turns into.
|
||||
|
||||
|
||||
% \cd@obeycrsp
|
||||
% Turns cr's into non-breakable spaces. Used by \cd.
|
||||
|
||||
{\catcode`\^^M=\active % these lines must end with %
|
||||
\gdef\cd@obeycrsp{\catcode`\^^M=\active\let^^M=\@xobeysp}}
|
||||
|
||||
% =============================================================================
|
||||
|
||||
% Set up code environment, in which most of the common special characters
|
||||
% appearing in code are treated verbatim, namely: $&#^_~%
|
||||
% \ { } are still enabled so that macros can be called in this
|
||||
% environment. Use \\, \{, and \} to use these characters verbatim
|
||||
% in this environment.
|
||||
%
|
||||
% Inside a group, you can make
|
||||
% all the hacked chars special with the \dcd command
|
||||
% $ special with the \cddollar command
|
||||
% $^_ special with the \cdmath command.
|
||||
% If you have a bunch of math $..$'s in your code env, then a global \cddollar
|
||||
% or \cdmath at the beginning of the env can save a lot of trouble.
|
||||
% When chars are special (e.g., after a \dcd), you can still get #$%&_{} with
|
||||
% \#, \$, \%, \&, \_, \{, and \} -- this is standard LaTeX.
|
||||
% Additionally, \\ gives \ inside the code env, and when \cdmath
|
||||
% makes ^ special, it also defines \^ to give ^.
|
||||
|
||||
%The hacked characters can be made special again
|
||||
% within a group by using the \dcd command.
|
||||
|
||||
% Note: this environment allows no breaking of lines whatsoever; not
|
||||
% at spaces or hypens. To arrange for a break use the standard \- command,
|
||||
% or a \discretionary{}{}{} which breaks, but inserts nothing. This is useful,
|
||||
% for example for allowing hypenated identifiers to be broken, e.g.
|
||||
% \def\={\discretionary{}{}{}} %optional break
|
||||
% FOO-\=BAR.
|
||||
|
||||
\def\setupcode{\parsep=0pt\parindent=0pt%
|
||||
\normalfont\ttfamily\frenchspacing\catcode``=13\@noligs%
|
||||
\def\\{\char`\\}%
|
||||
\let\dcd=\cd@dcd\let\cddollar=\cd@dollarspecial\let\cdmath=\cd@mathspecial%
|
||||
\@makeother\$\@makeother\&\@makeother\#%
|
||||
\@makeother\^\@makeother\_\@makeother\~%
|
||||
\@makeother\%\cd@obeytabs\cd@obeyspaces}
|
||||
% other: $&#^_~%
|
||||
% left special: \{}
|
||||
% unnecessary: @`'"
|
||||
|
||||
|
||||
%% codebox, centercode
|
||||
%%=============================================================================
|
||||
%% The codebox env makes a box exactly as wide as it needs to be
|
||||
%% (i.e., as wide as the longest line of code is). This is useful
|
||||
%% if you want to center a chunk of code, or flush it right, or
|
||||
%% something like that. The optional argument to the environment,
|
||||
%% [t], [c], or [b], specifies how to vertically align the codebox,
|
||||
%% just as with arrays or other boxes. Default is [c].
|
||||
|
||||
%% Must be a newline immediately after "\begin{codebox}[t]"!
|
||||
|
||||
{\catcode`\^^M=\active % these lines must end with %
|
||||
\gdef\cd@obeycr{\catcode`\^^M=\active\let^^M=\cr}}
|
||||
|
||||
% If there is a [<letter>] option, then the following newline will
|
||||
% be read *after* ^M is bound to \cr, so we're cool. If there isn't
|
||||
% an option given (i.e., default to [c]), then the @\ifnextchar will
|
||||
% gobble up the newline as it gobbles whitespace. So we insert the
|
||||
% \cr explicitly. Isn't TeX fun?
|
||||
\def\codebox{\leavevmode\@ifnextchar[{\@codebox}{\@codebox[c]\cr}} %]
|
||||
|
||||
\def\@codebox[#1]%
|
||||
{\hbox\bgroup$\if #1t\vtop \else \if#1b\vbox \else \vcenter \fi\fi\bgroup%
|
||||
\tabskip\z@\setupcode\cd@obeycr% just before cd@obey
|
||||
\halign\bgroup##\hfil\span}
|
||||
|
||||
\def\endcodebox{\crcr\egroup\egroup\m@th$\egroup}
|
||||
|
||||
% Center the box on the page:
|
||||
\newenvironment{centercode}%
|
||||
{\begin{center}\begin{codebox}[c]}%
|
||||
{\end{codebox}\end{center}}
|
||||
|
||||
|
||||
%% code, codeaux, tightcode
|
||||
%%=============================================================================
|
||||
%% Code environment as described above. Lines are kept on one page.
|
||||
%% This actually works by setting a huge penalty for breaking
|
||||
%% between lines of code. Code is indented same as other displayed paras.
|
||||
%% Note: to increase left margin, use \begin{codeaux}{\leftmargin=1in}.
|
||||
|
||||
% To allow pagebreaks, say \codeallowbreaks immediately inside the env.
|
||||
% You can allow breaks at specific lines with a \pagebreak form.
|
||||
|
||||
%% N.B.: The \global\@ignoretrue command must be performed just inside
|
||||
%% the *last* \end{...} before the following text. If not, you will
|
||||
%% get an extra space on the following line. Blech.
|
||||
|
||||
%% This environment takes two arguments.
|
||||
%% The second, required argument is the \list parameters to override the
|
||||
%% \@listi... defaults.
|
||||
%% - Usefully set by clients: \topsep \leftmargin
|
||||
%% - Possible, but less useful: \partopsep
|
||||
%% The first, optional argument is the extra \parskip glue that you get around
|
||||
%% \list environments. It defaults to the value of \parskip.
|
||||
\def\codeaux{\@ifnextchar[{\@codeaux}{\@codeaux[\parskip]}} %]
|
||||
\def\@codeaux[#1]#2{%
|
||||
\bgroup\parskip#1%
|
||||
\begin{list}{}%
|
||||
{\parsep\z@\rightskip\z@\listparindent\z@\itemindent\z@#2}%
|
||||
\item[]\setupcode\cd@obeylines}%
|
||||
\def\endcodeaux{\end{list}\leavevmode\egroup\ignorespaces\global\@ignoretrue}
|
||||
|
||||
%% Code env is codeaux with the default margin and spacing \list params:
|
||||
\def\code{\codeaux{}} \let\endcode=\endcodeaux
|
||||
|
||||
%% Like code, but with no extra vertical space above and below.
|
||||
\def\tightcode{\codeaux[=0pt]{\topsep\z@}}%
|
||||
\let\endtightcode\endcodeaux
|
||||
% {\vspace{-1\parskip}\begin{codeaux}{\partopsep\z@\topsep\z@}}%
|
||||
% {\end{codeaux}\vspace{-1\parskip}}
|
||||
|
||||
|
||||
|
||||
% Reasonable separation between lines of code
|
||||
\newcommand{\codeskip}{\penalty0\vspace{2ex}}
|
||||
|
||||
|
||||
% \cd is used to build a code environment in the middle of text.
|
||||
% Note: only difference from display code is that cr's are taken
|
||||
% as unbreakable spaces instead of linebreaks.
|
||||
|
||||
\def\cd{\leavevmode\begingroup\ifmmode\let\startcode=\startmcode\else%
|
||||
\let\startcode\starttcode\fi%
|
||||
\setupcode\cd@obeycrsp\startcode}
|
||||
|
||||
\def\starttcode#1{#1\endgroup}
|
||||
\def\startmcode#1{\hbox{#1}\endgroup}
|
||||
|
||||
|
||||
% Restore $&#^_~% to their normal catcodes
|
||||
% Define \^ to give the ^ char.
|
||||
% \dcd points to this guy inside a code env.
|
||||
\def\cd@dcd{\catcode`\$=3\catcode`\&=4\catcode`\#=6\catcode`\^=7%
|
||||
\catcode`\_=8\catcode`\~=13\catcode`\%=14\def\^{\char`\^}}
|
||||
|
||||
% Selectively enable $, and $^_ as special.
|
||||
% \cd@mathspecial also defines \^ give the ^ char.
|
||||
% \cddollar and \cdmath point to these guys inside a code env.
|
||||
\def\cd@dollarspecial{\catcode`\$=3}
|
||||
\def\cd@mathspecial{\catcode`\$=3\catcode`\^=7\catcode`\_=8%
|
||||
\def\^{\char`\^}}
|
||||
|
||||
|
||||
% Change log:
|
||||
% Started off as some macros found in C. Rich's library.
|
||||
% Olin 1/90:
|
||||
% Removed \makeatletter, \makeatother's -- they shouldn't be there,
|
||||
% because style option files are read with makeatletter. The terminal
|
||||
% makeatother screwed things up for the following style options.
|
||||
% Olin 3/91:
|
||||
% Rewritten.
|
||||
% - Changed things so blank lines don't get compressed out (the \leavevmove
|
||||
% in \cd@cr and \cd@crwb).
|
||||
% - Changed names to somewhat less horrible choices.
|
||||
% - Added lots of doc, so casual hackers can more easily mess with all this.
|
||||
% - Removed `'"@ from the set of hacked chars, since they are already
|
||||
% non-special.
|
||||
% - Removed the bigcode env, which effect can be had with the \codeallowbreaks
|
||||
% command.
|
||||
% - Removed the \@noligs command, since it's already defined in latex.tex.
|
||||
% - Win big with the new \dcd, \cddollar, and \cdmath commands.
|
||||
% - Now, *only* the chars \{} are special inside the code env. If you need
|
||||
% more, use the \dcd command inside a group.
|
||||
% - \cd now works inside math mode. (But if you use it in a superscript,
|
||||
% it still comes out full size. You must explicitly put a \scriptsize\tt
|
||||
% inside the \cd: $x^{\cd{\scriptsize\tt...}}$. A \leavevmode was added
|
||||
% so that if you begin a paragraph with a \cd{...}, TeX realises you
|
||||
% are starting a paragraph.
|
||||
% - Added the codebox env. Tricky bit involving the first line hacked
|
||||
% with help from David Long.
|
||||
% Olin 8/94
|
||||
% Changed the font commands for LaTeX2e.
|
||||
|
|
@ -1,114 +0,0 @@
|
|||
% css.t2p
|
||||
% Dorai Sitaram
|
||||
% 19 Jan 2001
|
||||
% A basic style for HTML documents generated
|
||||
% with tex2page.
|
||||
|
||||
\ifx\shipout\UNDEFINED
|
||||
\cssblock
|
||||
|
||||
body {
|
||||
color: black;
|
||||
/* background-color: #e5e5e5;*/
|
||||
background-color: #ffffff;
|
||||
/*background-color: beige;*/
|
||||
margin-top: 2em;
|
||||
margin-left: 8%;
|
||||
margin-right: 8%;
|
||||
}
|
||||
|
||||
h1,h2,h3,h4,h5,h6 {
|
||||
margin-top: .5em;
|
||||
}
|
||||
|
||||
.partheading {
|
||||
font-size: 100%;
|
||||
}
|
||||
|
||||
.chapterheading {
|
||||
font-size: 100%;
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
.schemeresponse {
|
||||
color: green;
|
||||
}
|
||||
|
||||
.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
|
||||
\fi
|
||||
|
||||
% ex:ft=css
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
% Loads cmtt fonts in on \tt. -*- latex -*-
|
||||
% I prefer these to the Courier fonts that latex gives you w/postscript styles.
|
||||
% Courier is too spidery and too wide -- it's hard to get 80 chars on a line.
|
||||
% -Olin
|
||||
|
||||
\renewcommand{\ttdefault}{cmtt}
|
||||
|
|
@ -1,336 +0,0 @@
|
|||
\makeatletter
|
||||
\def\ie{\mbox{\emph{i.e.}}} % \mbox keeps the last period from
|
||||
\def\Ie{\mbox{\emph{I.e.}}} % looking like an end-of-sentence.
|
||||
\def\eg{\mbox{\emph{e.g.}}}
|
||||
\def\Eg{\mbox{\emph{E.g.}}}
|
||||
\def\etc{{\em etc.}}
|
||||
|
||||
|
||||
|
||||
\def\Lisp{\textsc{Lisp}}
|
||||
\def\CommonLisp{\textsc{Common Lisp}}
|
||||
\def\Ascii{\textsc{Ascii}}
|
||||
\def\Ansi{\textsc{Ansi}}
|
||||
\def\Unix{{Unix}} % Not smallcaps, according to Bart.
|
||||
\def\Scheme{{Scheme}}
|
||||
\def\scm{{Scheme 48}}
|
||||
\def\RnRS{R5RS}
|
||||
\def\Posix{\textsc{Posix}}
|
||||
|
||||
\def\sharpf{\textnormal{\texttt{\#f}}}
|
||||
\def\sharpt{\textnormal{\texttt{\#t}}}
|
||||
\newcommand{\synteq}{\textnormal{::=}}
|
||||
|
||||
\def\maketildeother{\catcode`\~=12}
|
||||
\def\maketildeactive{\catcode`\~=13}
|
||||
\def\~{\char`\~}
|
||||
|
||||
\newcommand{\evalsto}{\ensuremath{\Rightarrow}}
|
||||
|
||||
% One-line code examples
|
||||
%\newcommand{\codex}[1]% One line, centred. Tight spacing.
|
||||
% {$$\abovedisplayskip=.75ex plus 1ex minus .5ex%
|
||||
% \belowdisplayskip=\abovedisplayskip%
|
||||
% \abovedisplayshortskip=0ex plus .5ex%
|
||||
% \belowdisplayshortskip=\abovedisplayshortskip%
|
||||
% \hbox{\ttt #1}$$}
|
||||
%\newcommand{\codex}[1]{\begin{tightinset}\ex{#1}\end{tightinset}\ignorespaces}
|
||||
\newcommand{\codex}[1]{\begin{leftinset}\ex{#1}\end{leftinset}\ignorespaces}
|
||||
|
||||
\def\widecode{\codeaux{\leftmargin=0pt\topsep=0pt}}
|
||||
\def\endwidecode{\endcodeaux}
|
||||
|
||||
% For multiletter vars in math mode:
|
||||
\newcommand{\var}[1]{\mbox{\frenchspacing\it{#1}}}
|
||||
\newcommand{\vari}[2]{\ensuremath{\mbox{\it{#1}}_{#2}}}
|
||||
|
||||
%% What you frequently want when you say \tt:
|
||||
\def\ttchars{\catcode``=13\@noligs\frenchspacing}
|
||||
\def\ttt{\normalfont\ttfamily\ttchars}
|
||||
|
||||
% Works in math mode; all special chars remain special; cheaper than \cd.
|
||||
% Will not be correct size in super and subscripts, though.
|
||||
\newcommand{\ex}[1]{{\normalfont\texttt{\ttchars #1}}}
|
||||
|
||||
\newenvironment{inset}
|
||||
{\bgroup\parskip=1ex plus 1ex\begin{list}{}%
|
||||
{\topsep=0pt\rightmargin\leftmargin}%
|
||||
\item[]}%
|
||||
{\end{list}\leavevmode\egroup\global\@ignoretrue}
|
||||
|
||||
\newenvironment{leftinset}
|
||||
{\bgroup\parskip=1ex plus 1ex\begin{list}{}%
|
||||
{\topsep=0pt}%
|
||||
\item[]}%
|
||||
{\end{list}\leavevmode\egroup\global\@ignoretrue}
|
||||
|
||||
\newenvironment{tightinset}
|
||||
{\bgroup\parskip=0pt\begin{list}{}%
|
||||
{\topsep=0pt\rightmargin\leftmargin}%
|
||||
\item[]}%
|
||||
{\end{list}\leavevmode\egroup\global\@ignoretrue}
|
||||
|
||||
\newenvironment{tightleftinset}
|
||||
{\bgroup\parskip=0pt\begin{list}{}%
|
||||
{\topsep=0pt}%
|
||||
\item[]}%
|
||||
{\end{list}\leavevmode\egroup\global\@ignoretrue}
|
||||
|
||||
\long\def\remark#1{\bgroup\small\begin{quote}\textsl{Remark: } #1\end{quote}\egroup}
|
||||
\newenvironment{remarkenv}{\bgroup\small\begin{quote}\textsl{Remark: }}%
|
||||
{\end{quote}\egroup}
|
||||
\newcommand{\oops}[1]{\bgroup\small\begin{quote}\textsl{Oops: } #1\end{quote}\egroup}
|
||||
|
||||
\newcommand{\note}[1]{\{Note #1\}}
|
||||
|
||||
\newcommand{\itum}[1]{\item{\bf #1}\\*}
|
||||
|
||||
% For use in code. The \llap magicness makes the lambda exactly as wide as
|
||||
% the other chars in \tt; the \hskip shifts it right a bit so it doesn't
|
||||
% crowd the left paren -- which is necessary if \tt is cmtt.
|
||||
% Note that (\l{x y} (+ x y)) uses the same number of columns in TeX form
|
||||
% as it produces when typeset. This makes it easy to line up the columns
|
||||
% in your input. \l is bound to some useless command in LaTeX, so we have to
|
||||
% define it w/renewcommand.
|
||||
\let\oldl\l %Save the old \l on \oldl
|
||||
\renewcommand{\l}[1]{\ \llap{$\lambda$\hskip-.05em}\ (#1)}
|
||||
|
||||
% This one is for the rare (lambda x ...) case -- it doesn't have the
|
||||
% column-invariant property. Oh, well.
|
||||
\newcommand{\lx}[1]{\ \llap{$\lambda$\hskip-.05em}\ {#1}}
|
||||
|
||||
% For subcaptions
|
||||
\newcommand{\subcaption}[1]
|
||||
{\unskip\vspace{-2mm}\begin{center}\unskip\em#1\end{center}}
|
||||
|
||||
%%% T release notes stuff
|
||||
\newlength{\notewidth}
|
||||
\setlength{\notewidth}{\textwidth}
|
||||
\addtolength{\notewidth}{-1.25in}
|
||||
|
||||
%\newcommand{\remark} [1]
|
||||
% {\par\vspace{\parskip}
|
||||
% \parbox[t]{.75in}{\sc Remark:}
|
||||
% \parbox[t]{\notewidth}{\em #1}
|
||||
% \vspace{\parskip}
|
||||
% }
|
||||
|
||||
\newenvironment{optiontable}%
|
||||
{\begin{tightinset}\renewcommand{\arraystretch}{1.5}%
|
||||
\begin{tabular}{@{}>{\ttt}ll@{}}}%
|
||||
{\end{tabular}\end{tightinset}}%
|
||||
|
||||
\newenvironment{desctable}[1]%
|
||||
{\begin{inset}\renewcommand{\arraystretch}{1.5}%
|
||||
\begin{tabular}{lp{#1}}}%
|
||||
{\end{tabular}\end{inset}}
|
||||
|
||||
\def\*{{\ttt *}}
|
||||
|
||||
% Names of things
|
||||
|
||||
\newcommand{\keyword} [1]{\index{#1}{\normalfont\textsf{#1}}}
|
||||
|
||||
% \ex{#1} and also generates an index entry.
|
||||
\newcommand{\exi}[1]{\index{#1@\texttt{#1}}\ex{#1}}
|
||||
\newcommand{\indextt}[1]{\index{#1@\texttt{#1}}}
|
||||
|
||||
|
||||
\newcommand{\evalto}{$\Longrightarrow$\ }
|
||||
\renewcommand{\star}{$^*$\/}
|
||||
\newcommand{\+}{$^+$}
|
||||
|
||||
% Semantic domains, used to indicate the type of a value
|
||||
|
||||
\newcommand{\sem}{\normalfont\itshape} %semantic font
|
||||
\newcommand{\semvar}[1]{\textit{#1}} %semantic font
|
||||
\newcommand{\synvar}[1]{\textrm{\textit{$\left<\right.$#1$\left.\right>$}}} %syntactic font
|
||||
\newcommand{\type}{\sem}
|
||||
\newcommand{\zeroormore}[1]{{\sem #1$_1$ \ldots #1$_n$}}
|
||||
\newcommand{\oneormore}[1]{{\sem #1$_1$ #1$_2$ \ldots #1$_n$}}
|
||||
|
||||
\newcommand{\proc} {{\sem procedure}}
|
||||
\newcommand{\boolean} {{\sem boolean}}
|
||||
\newcommand{\true} {{\sem true}}
|
||||
\newcommand{\false} {{\sem false}}
|
||||
|
||||
\newcommand{\num} {{\sem number}}
|
||||
\newcommand{\fixnum} {{\sem fixnum}}
|
||||
\newcommand{\integer} {{\sem integer}}
|
||||
\newcommand{\real} {{\sem real}}
|
||||
|
||||
\newcommand{\character} {{\sem character}}
|
||||
\newcommand{\str} {{\sem string}}
|
||||
\newcommand{\sym} {{\sem symbol}}
|
||||
|
||||
\newcommand{\location} {{\sem location}}
|
||||
\newcommand{\object} {{\sem object}}
|
||||
|
||||
\newcommand{\error} {{\sem error}}
|
||||
\newcommand{\syntaxerror} {{\sem syntax error}}
|
||||
\newcommand{\readerror} {{\sem read error}}
|
||||
\newcommand{\undefined} {{\sem undefined}}
|
||||
\newcommand{\noreturn} {{\sem no return value}}
|
||||
|
||||
\newcommand{\port} {{\sem port}}
|
||||
|
||||
% semantic variables
|
||||
|
||||
\newcommand{\identifier} {{\sem identifier}}
|
||||
\newcommand{\identifiers} {\zeroormore{\<ident>}}
|
||||
\newcommand{\expr} {{\sem expression}}
|
||||
\newcommand{\body} {{\sem body}}
|
||||
\newcommand{\valueofbody} {{\sem value~of~body}}
|
||||
\newcommand{\emptylist} {{\sem empty~list}}
|
||||
\newcommand{\car} {\keyword{car}}
|
||||
\newcommand{\cdr} {\keyword{cdr}}
|
||||
\newcommand{\TMPDIR}{\texttt{\$TMPDIR}}
|
||||
|
||||
% generally useful things
|
||||
|
||||
% For line-breaking \tt stuff.
|
||||
\renewcommand{\=}{\discretionary{-}{}{-}}
|
||||
\newcommand{\ob}{\discretionary{}{}{}} % Optional break.
|
||||
|
||||
\newcommand{\indx}[1]{#1 \index{ #1 }}
|
||||
%\newcommand{\gloss}[1]{#1 \glossary{ #1 }}
|
||||
|
||||
% This lossage produces #2 if #1 is zero length, otw #3.
|
||||
% We use it to conditionally add a space between the procedure and
|
||||
% the args in procedure prototypes, but only if there are any args--
|
||||
% we want to produce "(read)", not "(read )".
|
||||
\newlength{\voidlen}
|
||||
\newcommand{\testvoid}[3]{\settowidth\voidlen{#1}\ifdim\voidlen>0in{#3}\else{#2}\fi}
|
||||
|
||||
|
||||
% Typeset a definition prototype line, e.g.:
|
||||
% (cons <arg1> <arg2>) -> pair procedure
|
||||
%
|
||||
% Five args are: proc-name args ret-value(s) type index-entry
|
||||
\newcommand{\dfnix}[5]
|
||||
{\hbox to \linewidth{\ttchars%
|
||||
{\ttt(#1\testvoid{#2}{}{\ }{\sem{#2}}\testvoid{#2}{}{\/})\hskip 1em minus
|
||||
0.5em$\longrightarrow$\hskip 1em minus 0.5em{\sem{#3}}\hfill\quad\textnormal{#4}}}\index{#5}}
|
||||
|
||||
\newcommand{\dfnx}[4] {\dfnix{#1}{#2}{#3}{#4}{#1@\texttt{#1}}}
|
||||
|
||||
\newcommand{\dfn} {\par\medskip\dfnx} % Takes 4 args, actually.
|
||||
\newcommand{\dfni} {\par\medskip\dfnix} % Takes 5 args, actually.
|
||||
|
||||
\newcommand{\defvar} {\par\medskip\defvarx} % Takes 4 args, actually.
|
||||
\newcommand{\defvarx}[2]%
|
||||
{\index{#1}
|
||||
\hbox to \linewidth{\ttchars{{\ttt{#1}} \hfill #2}}}%
|
||||
|
||||
\newcommand{\defsyn}{\par\medskip\defsynx} % Takes 2 arguments, actually.
|
||||
\newcommand{\defsynx}[2]%
|
||||
{\index{#1}
|
||||
\hbox to \linewidth{\ttchars{{(#1 \ttt{#2})} \hfill syntax}}}%
|
||||
|
||||
|
||||
% 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}}
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%for surflet howto
|
||||
\def\surflet{SUrflet\xspace}
|
||||
\def\surflets{SUrflets\xspace}
|
||||
\def\scsh{scsh\xspace}
|
||||
\def\sunet{SUnet\xspace}
|
||||
|
||||
%From surflet/decls.tex
|
||||
%{\theoremstyle{break}
|
||||
%\theoremheaderfont{\normalfont\bfseries\em}
|
||||
% \newtheorem{proglist}{Listing}[section]}
|
||||
%\setlength{\theorempreskipamount}{1.5ex plus0.2ex minus0.2ex}
|
||||
%\setlength{\theorempostskipamount}{2ex plus0.5ex minus0.2ex}
|
||||
|
||||
% These environments differ from the other definition by the
|
||||
% positioning of \normalem
|
||||
\newenvironment{listing}
|
||||
{\ULforem\begin{alltt}\small\normalem}
|
||||
{\end{alltt}}
|
||||
|
||||
\newenvironment{reflisting}[1]
|
||||
{\ULforem[\refinlisting{#1}]\begin{alltt}\small\normalem}
|
||||
{\end{alltt}}
|
||||
|
||||
\newcommand{\contatlisting}[1]{%
|
||||
{\normalfont\textit{$<$continued in listing~\ref{#1}\/$>$}}}
|
||||
\newcommand{\contfromlisting}[1]{%
|
||||
{\normalfont\textit{$<$continued from listing~\ref{#1}\/$>$}}}
|
||||
\newcommand{\refinlisting}[1]{%
|
||||
{\normalfont\textit{referenced in listing~\ref{#1}}}}
|
||||
\newcommand{\seelisting}[1]{%
|
||||
{\normalfont{\textit{$<$see listing~\ref{#1}\/$>$}}}}
|
||||
|
||||
% Use url-package to get function names line-breaked at - / +
|
||||
% by infos in /usr/share/texmf/tex/latex/misc/url.sty
|
||||
%%\newcommand\breakfuntt{\begingroup \urlstyle{tt}%
|
||||
%%\@ifundefined{selectfont}{\def\UrlFont{\tt}}{\def\UrlFont{\ttfamily}}%
|
||||
%%\def\UrlBreaks{\do\-\do\/\do\+}\def\UrlNoBreaks{\do\!}\Url
|
||||
%%}
|
||||
|
||||
\newcommand{\name}[1]{\texttt{#1}}
|
||||
%\newcommand{\object}[1]{\breakfuntt{#1}}
|
||||
\newcommand{\file}[1]{\textttt{#1}}
|
||||
\newcommand{\codemph}[1]{\emph{#1}}
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
|
||||
\makeatother
|
||||
|
||||
|
||||
|
|
@ -1,482 +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.
|
||||
The library contains sophisticated replacements for scsh's interface
|
||||
to the \ex{gethostbyname} and \ex{gethostbyaddr} and many extensions
|
||||
to these functions.
|
||||
|
||||
The main features of the libraray include:
|
||||
\begin{itemize}
|
||||
\item Complete implementation of the DNS protocol
|
||||
\item Concurrent contacting of multiple DNS servers without blocking
|
||||
the scsh process
|
||||
\item Internal caching of DNS responses
|
||||
\item Parsing of \texttt{resolv.conf}, including \texttt{search}
|
||||
entries to generate FQDNs from unqualified host names
|
||||
\item Rich condition hierarchie
|
||||
\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{IP-address\xspace}
|
||||
\def\ipstring{IP-string\xspace}
|
||||
\def\fqdn{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
|
||||
accept. \var{Nameserver} is either a \ipaddr or a dotted IP string.
|
||||
|
||||
\defun{dns-lookup-name}{\fqdn [nameserver list][use-cache?]}{\ipaddr}
|
||||
\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}{\ipstring/\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}.
|
||||
\end{desc}
|
||||
|
||||
\defun{dns-lookup-nameserver}{\ipstring/\ipaddr [nameserver list][use-cache?]}{\ipaddr list}
|
||||
\begin{desc}
|
||||
Looks up an authoritative name server for a hostname, returns a list
|
||||
of name servers.
|
||||
\end{desc}
|
||||
|
||||
\defun{dns-lookup-mail-exchanger}{\ipstring/\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.
|
||||
\end{desc}
|
||||
\defun{socket-address->fqdn}{socket-address [nameserver list][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.
|
||||
\end{desc}
|
||||
|
||||
\defun{maybe-dns-lookup-name}{\fqdn [nameserver list][use-cache?]}{\ipaddr or \sharpf}
|
||||
\defunx{maybe-dns-lookup-ip}{\ipstring/\ipaddr [nameserver list][use-cache?]}{\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}.
|
||||
\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
|
||||
local host. These procedures use a list of domain names obtained
|
||||
from \texttt{/etc/resolv.conf} to the generate FQDNs and try to
|
||||
resolve these FQDNs.
|
||||
\end{desc}
|
||||
|
||||
\defun{dns-check-nameservers} {[nameserver list]} {\undefined}
|
||||
\begin{desc}
|
||||
\ex{dns-check-namservers} checks if the given nameservers are reachable.
|
||||
If no argument is given, the nameservers in \texttt{/etc/resolv.conf}
|
||||
are checked. Information about the status of the nameservers is printed
|
||||
to the current output port.
|
||||
\end{desc}
|
||||
|
||||
\section{Low-level Interface}
|
||||
|
||||
This section describes a set of data structures and procedures which
|
||||
directly correspond to the data flow of the DNS protocol. The central
|
||||
entity is a \var{message}, the abstraction of the packet sent to the
|
||||
server or received from the server (The DNS protocol uses the same
|
||||
data format for both directions). A \var{dns-message} encapsulates the
|
||||
query message sent to the server, the response message received from
|
||||
the server, and some additional information the library gathered while
|
||||
generating the \var{dns-message}.
|
||||
|
||||
\defunx{dns-get-information}{message protocol answer-okay? [nameserver
|
||||
list][use-cache?]}{dns-message}
|
||||
\begin{desc}
|
||||
Most general way to submit a DNS query. The message is sent to the
|
||||
name servers via \var{protocol} which can be either
|
||||
\ex{(network-procotcol tcp)} or {(network-protocol udp)}, both
|
||||
members of of the enumerated type \ex{network-protocol}. After
|
||||
receiving the reply, \ex{dns-get-information} applies the predicate
|
||||
\var{answer-okay?} to the message. If it returns \sharpf{} and the
|
||||
answer is not authoritative additional name servers sent with the
|
||||
reply are checked until an authoritative answer is found. If the
|
||||
predicate returns \sharpf{} but the answer is authoritative a
|
||||
\var{bad-address} condition is signalled.
|
||||
\end{desc}
|
||||
|
||||
\dfn{network-protocol}{protocol-name}{network-protocol}{syntax}
|
||||
\defunx{network-protocol?}{thing}{\boolean}
|
||||
\begin{desc}
|
||||
Constructor and predicate for the enumerated type
|
||||
\ex{network-protocol} with the possible protocol names \ex{tcp} and
|
||||
\ex{udp}.
|
||||
\end{desc}
|
||||
\defun{dns-lookup}{\ipstring/\ipaddr type [nameserver list][use-cache?]}{dns-message}
|
||||
\begin{desc}
|
||||
Convenient shortcut to submit a DNS query. The return value
|
||||
is a \ex{dns-message} structure:
|
||||
\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}{protocol}
|
||||
\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}{resource-record list}
|
||||
\defunx{message-nameservers}{message}{resource-record list}
|
||||
\defunx{message-additionals}{message}{resource-record 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{make-query-message header}{header question [questions]}{message}
|
||||
\begin{desc}
|
||||
The procedure generates a message the supplied questions,
|
||||
\var{header}, and the standard message values for queries.
|
||||
\end{desc}
|
||||
\defun{make-simple-query-message}{name type class}{message}
|
||||
\begin{desc}
|
||||
This simplified constructor generates a message with one question
|
||||
which is built from the parameters, and the standard header flags
|
||||
for queries and the standard message values for queries.
|
||||
\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-zero}{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:
|
||||
\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 enumerated type,
|
||||
\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-number}{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{resource-record?}{thing}{\boolean}
|
||||
\defunx{resource-record-name}{resource-record}{\str}
|
||||
\defunx{resource-record-type}{resource-record}{message-type}
|
||||
\defunx{resource-record-class}{resource-record}{message-class}
|
||||
\defunx{resource-record-ttl}{resource-record}{number}
|
||||
\defunx{resource-record-data}{resource-record}{resource-record-data-\dots}
|
||||
\begin{desc}
|
||||
A resource record as returned from the DNS server. The actual data
|
||||
of the record is stored in the \texttt{resource-record-data} field.
|
||||
It is one of the record types for resource record data described
|
||||
below.
|
||||
\end{desc}
|
||||
|
||||
\defun{resource-record-data-a?}{thing}{\boolean}
|
||||
\defunx{resource-record-data-a-ip}{resource-record-data-a}{\ipaddr}
|
||||
\begin{desc}
|
||||
An address resource record which holds an internet address.
|
||||
\end{desc}
|
||||
|
||||
\defun{resource-record-data-ns?}{thing}{\boolean}
|
||||
\defunx{resource-record-data-ns-name}{resource-record-data-ns}{\fqdn}
|
||||
\begin{desc}
|
||||
A name server resource record containing the FQDN of the name server.
|
||||
\end{desc}
|
||||
|
||||
\defun{resource-record-data-cname?}{thing}{\boolean}
|
||||
\defunx{resource-record-data-cname-name}{resource-record-data-cname}{\fqdn}
|
||||
\begin{desc}
|
||||
A canonical name resource record which contains the canonical or
|
||||
primary name of the owner.
|
||||
\end{desc}
|
||||
|
||||
\defun{resource-record-data-mx?}{thing}{\boolean}
|
||||
\defunx{resource-record-data-mx-preference}{resource-record-data-mx}{number}
|
||||
\defunx{resource-record-data-mx-exchanger}{resource-record-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{resource-record-data-ptr?}{thing}{\boolean}
|
||||
\defunx{resource-record-data-ptr-name}{resource-record-data-ptr}{\str}
|
||||
\begin{desc}
|
||||
A pointer resource record which points to some other domain name.
|
||||
\end{desc}
|
||||
|
||||
\defun{resource-record-data-soa?}{thing}{\boolean}
|
||||
\defunx{resource-record-data-soa-mname}{resource-record-data-soa}{\fqdn}
|
||||
\defunx{resource-record-data-soa-rname}{resource-record-data-soa}{\fqdn}
|
||||
\defunx{resource-record-data-soa-serial}{resource-record-data-soa}{number}
|
||||
\defunx{resource-record-data-soa-refresh}{resource-record-data-soa}{number}
|
||||
\defunx{resource-record-data-soa-retry}{resource-record-data-soa}{number}
|
||||
\defunx{resource-record-data-soa-expire}{resource-record-data-soa}{number}
|
||||
\defunx{resource-record-data-soa-minimum}{resource-record-data-soa}{number}
|
||||
\begin{desc}
|
||||
A start of a zone of authority resource record.
|
||||
\end{desc}
|
||||
The protocol specifies other possible values for the \texttt{resource-record-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{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.
|
||||
\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} and \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}
|
||||
%
|
||||
\begin{description}
|
||||
\item[Used files:] ip.scm
|
||||
\item[Name of the package:] ips
|
||||
\end{description}
|
||||
%
|
||||
|
||||
The structure \ex{ips} provides a small set of procedures for turning
|
||||
the human-readable form of IP addresses (``dotted strings'') into 32
|
||||
bits numbers.
|
||||
|
||||
\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} is a valid dotted string for an IP
|
||||
address.
|
||||
\end{desc}
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,163 +0,0 @@
|
|||
\chapter{FTP Client}\label{cha:ftp}
|
||||
|
||||
The \ex{ftp} structure lets you transfer files between networked
|
||||
machines from the Scheme Shell, using the File Transfer Protocol as
|
||||
described in RFC~959.
|
||||
|
||||
Some of the procedures in this module extract useful information from
|
||||
the server's reply, such as the size of a file, or the name of the
|
||||
directory we have moved to. These procedures return the extracted
|
||||
information, or, if the server's response doesn't match the expected
|
||||
code from the server, a catchable \ex{ftp-error} is raised.
|
||||
|
||||
\defun{ftp-connect}{host login password passive? [log-port]}{connection}
|
||||
\begin{desc}
|
||||
Open a command connection with the remote machine \var{host} and
|
||||
login on that server with \var{login} and \var{password}.
|
||||
\var{Login} and \var{password} can be \sharpf, in which case the
|
||||
information is extracted from the user's \ex{.netrc} file if necessary.
|
||||
|
||||
If \var{log-port} is specified, it must be an output port: this
|
||||
starts logging the conversation with the server to that port. Note
|
||||
that the log contains passwords in clear text.
|
||||
\end{desc}
|
||||
|
||||
\dfn{ftp-type}{\synvar{name}}{ftp-type}{syntax}
|
||||
\defunx{ftp-set-type!}{connection ftp-type}{undefined}
|
||||
\begin{desc}
|
||||
This change the transfer mode for future file transfers. The
|
||||
transfer mode is specfified by \var{ftp-type} which can be created
|
||||
with the \ex{ftp-type} macro. \synvar{Name} must be either
|
||||
\ex{binary} for binary data or \ex{ascii} for text.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-rename}{connection old new}{undefined}
|
||||
\begin{desc}
|
||||
This changes the name of \var{old} on the remote host to \var{new}
|
||||
(assuming sufficient permissions). \var{Old} and \var{new} are
|
||||
strings.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-delete}{connection file}{undefined}
|
||||
\begin{desc}
|
||||
This deletes \var{file} from the remote host (assuming the user has
|
||||
appropriate permissions).
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-cd}{connection dir}{undefined}
|
||||
\begin{desc}
|
||||
This changes the current directory on the server.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-cdup}{connection}{undefined}
|
||||
\begin{desc}
|
||||
This move to the parent directory on the server.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-pwd}{connection}{string}
|
||||
\begin{desc}
|
||||
Return the current directory on the remote host, as a string.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-ls}{connection [dir]}{list}
|
||||
\begin{desc}
|
||||
This returns a list of filenames on the remote host, either from the
|
||||
current directory (if \var{dir} is not specified), or from the
|
||||
directory specified by \var{dir}.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-dir}{connection [dir]}{status}
|
||||
\begin{desc}
|
||||
This returns a list of long-form file name entries on the remote
|
||||
host, either from the current directory (if \var{dir} is not
|
||||
specified), or from the directory specified by \var{dir}. (Note
|
||||
that the format for the long-form entries is not specified by the
|
||||
FTP standard.)
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-get}{connection remote-file proc}{undefined}
|
||||
\begin{desc}
|
||||
This downloads \var{remote-file} from the FTP server.
|
||||
\ex{Ftp-get} establishes a data conneciton to the server, attaches
|
||||
an input port to the data connection, and calls \var{proc} on that
|
||||
port.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-put}{connection remote-file proc}{undefined}
|
||||
\begin{desc}
|
||||
This uploads \var{remote-file} to the FTP server. \ex{Ftp-put}
|
||||
establishes a data conneciton to the server, attaches an output port
|
||||
to the data connection, and calls \var{proc} on that port.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-append}{connection remote-file proc}{undefined}
|
||||
\begin{desc}
|
||||
This appends data to \var{remote-file} on the FTP server.
|
||||
\ex{Ftp-append} establishes a data conneciton to the server,
|
||||
attaches an output port to the data connection, and calls \var{proc}
|
||||
on that port.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-rmdir}{connection dir}{undefined}
|
||||
\begin{desc}
|
||||
This removes the directory \var{dir} from the remote host (assuming
|
||||
sufficient permissions).
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-mkdir}{connection dir}{undefined}
|
||||
\begin{desc}
|
||||
This create a new directory named \var{dir} on the remote host
|
||||
(assuming sufficient permissions).
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-modification-time}{connection file}{date}
|
||||
\begin{desc}
|
||||
This requests the time of the last modification of \var{file} on the
|
||||
remote host, and on success return a Scsh date record. (This command
|
||||
is not part of RFC~959 and is not implemented by all servers, but is
|
||||
useful for mirroring.)
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-size}{connection file}{integer}
|
||||
\begin{desc}
|
||||
This returns the size of \var{file} in bytes. (This command is not
|
||||
part of RFC~959 and is not implemented by all servers.)
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-quit}{connection}{undefined}
|
||||
\begin{desc}
|
||||
This closes the connection to the remote host. The \var{connection}
|
||||
object is useless after a quit command.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-quot}{connection command}{status}
|
||||
\begin{desc}
|
||||
This sends a \var{command} verbatim to the remote server and wait
|
||||
for a response. The response text is returned verbatim.
|
||||
\end{desc}
|
||||
|
||||
\defun{ftp-error?}{thing}{boolean}
|
||||
\begin{desc}
|
||||
This returns \sharpt{} if \var{thing} is a \ex{ftp-error} object,
|
||||
otherwise \sharpf.
|
||||
\end{desc}
|
||||
|
||||
\defun{copy-port->port-binary}{input-port oputput-port}{undefined}
|
||||
\defunx{copy-port->port-ascii}{input-port oputput-port}{undefined}
|
||||
\defunx{copy-ascii-port->port}{input-port oputput-port}{undefined}
|
||||
\begin{desc}
|
||||
These procedures are useful for downloading and uploading data to an
|
||||
FTP connection via \ex{ftp-get}, \ex{ftp-get}, and \ex{ftp-append}.
|
||||
They all copy data from one port to another.
|
||||
\ex{Copy-port->port-binary} copies verbatim, while the other two
|
||||
perform CR/LF conversion for ASCII data transfers.
|
||||
\ex{Copy-port->port-ascii} adds CR/LFs at line endings on output,
|
||||
whereas \ex{Copy-ascii-port->port} removes CR/LFs at line endings
|
||||
end replaces them by ordinary LFs.
|
||||
\end{desc}
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
\chapter{FTP Server}\label{cha:ftpd}
|
||||
|
||||
The \ex{ftpd} structure contains a complete anonymous ftp server.
|
||||
|
||||
\defun{ftpd}{options}{\noreturn}
|
||||
\defunx{ftp-inetd}{options}{\noreturn}
|
||||
\begin{desc}
|
||||
\ex{Ftpd} starts the server, using \var{anonymous-home} as the
|
||||
root directory of the server.
|
||||
|
||||
\ex{ftpd-inetd} is the version to be used from \ex{inetd}.
|
||||
\ex{Ftpd-inetd} handles the connection through the current standard
|
||||
output and input ports.
|
||||
\end{desc}
|
||||
%
|
||||
The \var{options} argument can be constructed through a number of
|
||||
procedures with names of the form \texttt{with-\ldots}. Each of these
|
||||
procedures either creates a fresh options value or adds a
|
||||
configuration parameter to an old options argument. The configuration
|
||||
parameter value is always the first argument, the (old) options value
|
||||
the optional second one. Here they are:
|
||||
|
||||
\defun{with-port}{port [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the port on which the server listens. Defaults to 21.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-anonymous-home}{string [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the home directory for anonymous logins. Defaults to
|
||||
\verb|"~ftp"|.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-banner}{list [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies an alternative greeting banner for those members of
|
||||
the Untergrund who prefer to remain covert. The banner is
|
||||
represented as a list of strings, one for each line of output.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-log-port}{output-port [options]}{options}
|
||||
\begin{desc}
|
||||
If this is non-\sharpf, ex{ftpd} outputs a log entry for each file
|
||||
sent or retrieved on \var{output-port}. Defaults to \sharpf.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-dns-lookup?}{boolean [options]}{options}
|
||||
\begin{desc}
|
||||
If \var{dns-lookup?} is \sharpt, the log file will contain the host
|
||||
names instead of their IP addresses. If \var{dns-lookup?} is \sharpf,
|
||||
the log will only contain IP addresses. Defaults to \sharpf.
|
||||
\end{desc}
|
||||
%
|
||||
The \ex{make-ftpd-options} eases the construction of the options
|
||||
argument:
|
||||
%
|
||||
\defun{make-ftpd-options}{transformer value \ldots}{options}
|
||||
\begin{desc}
|
||||
This constructs an options value from an argument list of parameter
|
||||
transformers and parameter values. The arguments come in pairs,
|
||||
each an option transformer from the list above, and a value for that
|
||||
parameter. \ex{Make-ftpd-options} returns the resulting options value.
|
||||
\end{desc}
|
||||
|
||||
The log format of \ex{ftpd} is the same as the one of
|
||||
\ex{wuftpd}. The entries look like this:
|
||||
%
|
||||
\begin{verbatim}
|
||||
Fri Apr 19 17:08:14 2002 4 134.2.2.171 56881 /files.lst b _ i a nop@ssword ftp 0 *
|
||||
\end{verbatim}
|
||||
%
|
||||
These are the fields:
|
||||
\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 (wu-ftpd 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, it always has \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.
|
||||
\item Service name---always \ex{ftp}.
|
||||
\item Authentication mode (always ``none'' = `\ex{0}').
|
||||
\item Authenticated user ID (always ``not available'' = `\ex{*}')
|
||||
\end{enumerate}
|
||||
|
||||
The server also writes log information to the syslog facility.
|
||||
The following syslog levels occur in the output:
|
||||
\begin{description}
|
||||
\item[\ex{notice}]
|
||||
\begin{itemize}
|
||||
\item messages concerning \emph{connections} (establishing connection,
|
||||
connection refused, closing connection due to timeout, etc.)
|
||||
\item the execution of the \ex{STOR} command\\
|
||||
Its success (\ie
|
||||
somebody is putting something on your server via ftp, also known as
|
||||
\ex{PUT}) is also logged at \ex{notice}.
|
||||
\item internal errors
|
||||
\item Unix errors
|
||||
\item reaching of actually unreachable case branches
|
||||
\end{itemize}
|
||||
\item[\ex{info}] Messages concerning all other commands,
|
||||
including the \ex{RETR} command.
|
||||
\item[\ex{debug}] all other messages, including debug messages
|
||||
\end{description}
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
% headings.tex -*- latex -*-
|
||||
% Quieter headings that the ones used in article.sty.
|
||||
% This is not a style option. Don't say [headings].
|
||||
% Instead, say \input{headings} after the \documentstyle.
|
||||
% -Olin 7/91
|
||||
|
||||
\makeatletter
|
||||
|
||||
\def\section{\@startsection {section}{1}{\z@}{-3.5ex plus -1ex minus
|
||||
-.2ex}{2.3ex plus .2ex}{\large\normalfont\bfseries}}
|
||||
\def\subsection{\@startsection{subsection}{2}{\z@}{-3.25ex plus -1ex minus
|
||||
-.2ex}{1.5ex plus .2ex}{\normalsize\normalfont\bfseries}}
|
||||
\def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-3.25ex plus
|
||||
-1ex minus -.2ex}{1.5ex plus .2ex}{\normalsize\normalfont\bfseries}}
|
||||
|
||||
\makeatother
|
||||
|
|
@ -1,742 +0,0 @@
|
|||
\chapter{HTTP server}\label{cha:httpd}
|
||||
%
|
||||
The SUnet HTTP Server is a complete industrial-strength implementation
|
||||
of the HTTP 1.0 protocol. It is highly configurable and allows the writing
|
||||
of dynamic web pages that run inside the server without going through
|
||||
complicated and slow protocols like CGI or Fast/CGI.
|
||||
|
||||
\section{Starting and configuring the server}
|
||||
|
||||
All procedures described in this section are exported by the
|
||||
\texttt{httpd} structure.
|
||||
|
||||
The Web server is started by calling the \ex{httpd} procedure, which takes
|
||||
one argument, an options value:
|
||||
|
||||
\defun{httpd}{options}{\noreturn}
|
||||
\begin{desc}
|
||||
This procedure starts the server. The \var{options} argument
|
||||
specifies various configuration parameters, explained below.
|
||||
|
||||
The server's basic loop is to wait on the port for a connection from
|
||||
an HTTP client. When it receives a connection, it reads in and
|
||||
parses the request into a special request data structure. Then the
|
||||
server forks a thread which binds the current I/O ports to the
|
||||
connection socket, and then hands off to the top-level
|
||||
request handler (which must be specified in the options). The
|
||||
request handler is responsible for actually serving
|
||||
the request---it can be any arbitrary computation. Its output goes
|
||||
directly back to the HTTP client that sent the request.
|
||||
|
||||
Before calling the request handler to service the request, the HTTP
|
||||
server installs an error handler that fields any uncaught error,
|
||||
sends an error reply to the client, and aborts the request
|
||||
transaction. Hence any error caused by a request handler will be
|
||||
handled in a reasonable and robust fashion.
|
||||
\end{desc}
|
||||
%
|
||||
The \var{options} argument can be constructed through a number of procedures
|
||||
with names of the form \texttt{with-\ldots}. Each of these procedures
|
||||
either creates a fresh options value or adds a configuration parameter
|
||||
to an old options argument. The configuration parameter value is
|
||||
always the first argument, the (old) options value the optional second
|
||||
one. Here they are:
|
||||
|
||||
\defun{with-port}{port [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the port on which the server listens. Defaults to 80.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-root-directory}{root-directory [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the current directory of the server. Note that this
|
||||
is \emph{not} the document root directory. Defaults to \texttt{/}.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-fqdn}{fqdn [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the fully-qualified domain name the server uses in
|
||||
automatically generated replies, or \ex{\#f} if the server should
|
||||
query DNS for the fully-qualified domain name.. Defaults to \ex{\#f}.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-reported-port}{reported-port [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the port number the server uses in automatically
|
||||
generated replies or \ex{\#f} if the reported port is the same as
|
||||
the port the server is listening on. (This is useful if you're
|
||||
running the server through an accelerating proxy.) Defaults to
|
||||
\ex{\#f}.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-server-admin}{mail-address [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the email address of the server administrator the
|
||||
server uses in automatically generated replies. Defaults to \ex{\#f}.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-request-handler}{request-handler [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the request handler of the server to which the server
|
||||
delegates the actual work. More on that subject below in
|
||||
Section~\ref{httpd:request-handlers}. This parameter must be specified.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-simultaneous-requests}{requests [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies a limit on the number of simultaneous requests the
|
||||
server servers. If that limit is exceeded during operation, the
|
||||
server will hold off on new requests until the number of
|
||||
simultaneous requests has sunk below the limit again. If this
|
||||
parameter is \ex{\#f}, no limit is imposed. Defaults to \ex{\#f}.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-log-file}{log-file [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies the name of a log file for the server where it writes
|
||||
Common Log Format logging information. It can also be a port in
|
||||
which case the information is logged to that port, or \ex{\#f} for
|
||||
no logging. Defaults to \ex{\#f}.
|
||||
|
||||
To allow rotation of log files, the server re-opens the log file
|
||||
whenever it receives a \texttt{USR1} signal.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-syslog?}{syslog? [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies whether the server will log information about
|
||||
incoming to the Unix syslog facility. Defaults to \ex{\#t}.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-resolve-ips?}{resolve-ip? [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies whether the server writes the domain names rather
|
||||
than numerical IPs to the output log it produces. Defaults to
|
||||
\ex{\#t}.
|
||||
\end{desc}
|
||||
|
||||
To avoid paranthitis, the \ex{make-httpd-options} procedure eases the
|
||||
construction of the options argument:
|
||||
|
||||
\defun{make-httpd-options}{transformer value \ldots}{options}
|
||||
\begin{desc}
|
||||
This constructs an options value from an argument list of parameter
|
||||
transformers and parameter values. The arguments come in pairs,
|
||||
each an option transformer from the list above, and a value for that
|
||||
parameter. \ex{Make-httpd-options} returns the resulting options value.
|
||||
\end{desc}
|
||||
|
||||
For example,
|
||||
\begin{alltt}
|
||||
(httpd (make-httpd-options
|
||||
with-request-handler (rooted-file-handler "/usr/local/etc/httpd")
|
||||
with-root-directory "/usr/local/etc/httpd"))
|
||||
\end{alltt}
|
||||
%
|
||||
starts the server on port 80 with
|
||||
\ex{/usr/local/etc/httpd} as its root directory and
|
||||
lets it serve any file out from this directory.
|
||||
% #### note about rooted-file-handler
|
||||
|
||||
|
||||
\section{Requests}
|
||||
\label{httpd:requests}
|
||||
|
||||
Request handlers operate on \textit{requests} which contain the
|
||||
information needed to generate a page. The relevant procedures to
|
||||
dissect requests are defined in the \texttt{httpd-requests} structure:
|
||||
|
||||
\defun{request?}{value}{boolean}
|
||||
\defunx{request-method}{request}{string}
|
||||
\defunx{request-uri}{request}{string}
|
||||
\defunx{request-url}{request}{url}
|
||||
\defunx{request-version}{request}{pair}
|
||||
\defunx{request-headers}{request}{list}
|
||||
\defunx{request-socket}{request}{socket}
|
||||
\begin{desc}
|
||||
The procedure inspect request values. \ex{Request?} is a predicate
|
||||
for requests. \ex{Request-method} extracts the method of the HTTP
|
||||
request; it's a string such as \verb|"GET"|, \verb|"PUT"|.
|
||||
\ex{Request-uri} returns the escaped URI string as read from request
|
||||
line. \ex{Request-url} returns an HTTP URL value (see the
|
||||
description of the \ex{url} structure in \ref{cha:url}).
|
||||
\ex{Request-version} returns \verb|(major . minor)| integer pair
|
||||
representing the version specified in the HTTP request.
|
||||
\ex{Request-headers} returns an association lists of header field
|
||||
names and their values, each represented by a list of strings, one
|
||||
for each line. \ex{Request-socket} returns the socket connected
|
||||
to the client.\footnote{Request handlers should not perform I/O on the
|
||||
request record's socket. Request handlers are frequently called
|
||||
recursively, and doing I/O directly to the socket might bypass a
|
||||
filtering or other processing step interposed on the current I/O ports
|
||||
by some superior request handler.}
|
||||
\end{desc}
|
||||
|
||||
\section{Responses}
|
||||
\label{sec:http-responses}
|
||||
|
||||
A path handler must return a \textit{response} value representing the
|
||||
content to be sent to the client. The machinery presented here for
|
||||
constructing responses lives in the \ex{httpd-responses} structure.
|
||||
|
||||
\defun{make-response}{status-code maybe-message seconds mime extras
|
||||
body}{response}
|
||||
\begin{desc}
|
||||
This procedure constructs a response value. \var{Status-code} is an
|
||||
HTTP status code (more on that below). \var{Maybe-message} is a a
|
||||
message elaborating on the circumstances of the status code; it can
|
||||
also be \sharpf{} meaning that the server should send a default
|
||||
message associated with the status code. \var{Seconds} natural
|
||||
number indicating the time the content was created, typically the
|
||||
value of \verb|(time)|. \var{Mime} is a string indicating the MIME
|
||||
type of the response (such as \verb|"text/html"| or
|
||||
\verb|"application/octet-stream"|). \var{Extras} is an association
|
||||
list with extra headers to be added to the response; its elements
|
||||
are pairs, each of which consists of a symbol representing the field
|
||||
name and a string representing the field value. \var{Body}
|
||||
represents the body of the response; more on that below.
|
||||
\end{desc}
|
||||
|
||||
\defun{make-redirect-response}{location}{response}
|
||||
\begin{desc}
|
||||
This is a helper procedure for constructing HTTP redirections. The
|
||||
server will serve the new file indicated by \var{location}.
|
||||
\var{Location} must be URI-encoded and begin with a slash.
|
||||
\end{desc}
|
||||
|
||||
\defun{make-error-response}{status-code request [message] extras \ldots}{response}
|
||||
\begin{desc}
|
||||
This is a helper procedure for constructing error responses.
|
||||
\var{code} is status code of the response (see below). \var{Request}
|
||||
is the request that led to the error. \var{Message} is an optional
|
||||
string containing an error message written in HTML, and \var{extras}
|
||||
are further optional arguments containing further message lines to
|
||||
be added to the web page that's generated.
|
||||
|
||||
\ex{Make-error-response} constructs a response value which generates
|
||||
a web page containg a short explanatory message for the error at hand.
|
||||
\end{desc}
|
||||
|
||||
\begin{table}[htb]
|
||||
\centering
|
||||
\begin{tabular}{|l|l|l|}
|
||||
\hline
|
||||
ok & 200 & OK\\\hline
|
||||
created & 201 & Created\\\hline
|
||||
accepted & 202 & Accepted\\\hline
|
||||
prov-info & 203 & Provisional Information\\\hline
|
||||
no-content & 204 & No Content\\\hline
|
||||
|
||||
mult-choice & 300 & Multiple Choices\\\hline
|
||||
moved-perm & 301 & Moved Permanently\\\hline
|
||||
moved-temp & 302 & Moved Temporarily\\\hline
|
||||
method & 303 & Method (obsolete)\\\hline
|
||||
not-mod & 304 & Not Modified\\\hline
|
||||
|
||||
bad-request & 400 & Bad Request\\\hline
|
||||
unauthorized & 401 & Unauthorized\\\hline
|
||||
payment-req & 402 & Payment Required\\\hline
|
||||
forbidden & 403 & Forbidden\\\hline
|
||||
not-found & 404 & Not Found\\\hline
|
||||
method-not-allowed & 405 & Method Not Allowed\\\hline
|
||||
none-acceptable & 406 & None Acceptable\\\hline
|
||||
proxy-auth-required & 407 & Proxy Authentication Required\\\hline
|
||||
timeout & 408 & Request Timeout\\\hline
|
||||
conflict & 409 & Conflict\\\hline
|
||||
gone & 410 & Gone\\\hline
|
||||
internal-error & 500 & Internal Server Error\\\hline
|
||||
not-implemented & 501 & Not Implemented\\\hline
|
||||
bad-gateway & 502 & Bad Gateway\\\hline
|
||||
service-unavailable & 503 & Service Unavailable\\\hline
|
||||
gateway-timeout & 504 & Gateway Timeout\\\hline
|
||||
\end{tabular}
|
||||
\caption{HTTP status codes}
|
||||
\label{tab:status-code-names}
|
||||
\end{table}
|
||||
|
||||
\dfn{status-code}{\synvar{name}}{status-code}{syntax}
|
||||
\defunx{name->status-code}{symbol}{status-code}
|
||||
\defunx{status-code-number}{status-code}{integer}
|
||||
\defunx{status-code-message}{status-code}{string}
|
||||
\begin{desc}
|
||||
The \ex{status-code} syntax returns a status code where
|
||||
\synvar{name} is the name from Table~\ref{tab:status-code-names}.
|
||||
\ex{Name->status-code} also returns a status code for a name
|
||||
represented as a symbol. For a given status code,
|
||||
\ex{status-code-number} extracts its number, and
|
||||
\ex{status-code-message} extracts its associated default message.
|
||||
\end{desc}
|
||||
|
||||
\section{Response Bodies}
|
||||
\label{httpd:response-bodies}
|
||||
|
||||
A \textit{response body} represents the body of an HTTP response.
|
||||
There are several types of response bodies, depending on the
|
||||
requirements on content generation.
|
||||
|
||||
\defun{make-writer-body}{proc}{body}
|
||||
\begin{desc}
|
||||
This constructs a response body from a \textit{writer}---a procedure
|
||||
that prints the page contents to a port. The \var{proc} argument
|
||||
must be a procedure accepting an output port (to which \var{proc}
|
||||
prints the body) and the options value passed to the \ex{httpd}
|
||||
invocation.
|
||||
\end{desc}
|
||||
|
||||
\defun{make-reader-writer-body}{proc}{body}
|
||||
\begin{desc}
|
||||
This constructs a response body from a \textit{reader/writer}---a
|
||||
procedure that prints the page contents to a port, possibly after
|
||||
reading input from the socket of the HTTP connection. The
|
||||
\var{proc} argument must be a procedure accepting three arguments:
|
||||
an input port (associated with the HTTP connection socket), an
|
||||
output port (to which \var{proc} prints the body), and the options
|
||||
value passed to the \ex{httpd} invocation.
|
||||
\end{desc}
|
||||
|
||||
\section{Request Handlers}
|
||||
\label{httpd:request-handlers}
|
||||
|
||||
A request handler generates the actual content for a request; request
|
||||
handlers form a simple algebra and may be combined and composed in
|
||||
various ways.
|
||||
|
||||
|
||||
A request handler is a procedure of two arguments like this:
|
||||
\defun{request-handler}{path req}{response}
|
||||
\begin{desc}
|
||||
\var{Req} is a request. The \semvar{path} argument is the URL's
|
||||
path, parsed and split at slashes into a string list. For example,
|
||||
if the Web client dereferences URL
|
||||
%
|
||||
\begin{verbatim}
|
||||
http://clark.lcs.mit.edu:8001/h/shivers/code/web.tar.gz
|
||||
\end{verbatim}
|
||||
then the server would pass the following path to the top-level
|
||||
handler:
|
||||
%
|
||||
\begin{verbatim}
|
||||
("h" "shivers" "code" "web.tar.gz")
|
||||
\end{verbatim}
|
||||
%
|
||||
The \var{path} argument's pre-parsed representation as a string
|
||||
list makes it easy for the request handler to implement recursive
|
||||
operations dispatch on URL paths.
|
||||
|
||||
The request handler must return an HTTP response.
|
||||
\end{desc}
|
||||
|
||||
\subsection{Basic Request Handlers}
|
||||
|
||||
The web server comes with a useful toolbox of basic request handlers
|
||||
that can be used and built upon. The following procedures are
|
||||
exported by the \ex{httpd\=basic\=handlers} structure:
|
||||
|
||||
\defvar{null-request-handler}{request-handler}
|
||||
\begin{desc}
|
||||
This request handler always generated a \ex{not-found} error
|
||||
response, no patter what the request is.
|
||||
\end{desc}
|
||||
|
||||
\defun{make-predicate-handler}{predicate handler
|
||||
default-handler}{request-handler}
|
||||
\begin{desc}
|
||||
The request handler returned by this procedure first calls
|
||||
\var{predicate} on its path and request; it then acts like
|
||||
\var{handler} if the predicate returned a true vale, and like
|
||||
\var{default-handler} if the predicate returned \sharpf.
|
||||
\end{desc}
|
||||
|
||||
\defun{make-host-name-handler}{hostname handler default-handler}{request-handler}
|
||||
\begin{desc}
|
||||
The request handler returned by this procedure compares the host
|
||||
name specified in the request with \var{hostname}: if they match, it
|
||||
acts like \var{handler}, otherwise, it acts like
|
||||
\var{default-handler}.
|
||||
\end{desc}
|
||||
|
||||
\defun{make-path-predicate-handler}{predicate handler
|
||||
default-handler}{request-handler}
|
||||
\begin{desc}
|
||||
The request handler returned by this procedure first calls
|
||||
\var{predicate} on its path; it then acts like \var{handler} if the
|
||||
predicate returned a true vale, and like \var{default-handler} if
|
||||
the predicate returned \sharpf.
|
||||
\end{desc}
|
||||
|
||||
\defun{make-path-prefix-handler}{path-prefix handler default-handler}{request-handler}
|
||||
\begin{desc}
|
||||
This constructs a request handler that calls \var{handler} on its
|
||||
argument if \var{path-prefix} (a string) is the first element of the
|
||||
requested path; it calls \var{handler} on the rest of the path and
|
||||
the original request. Otherwise, the handler acts like
|
||||
\var{default-handler}.
|
||||
\end{desc}
|
||||
|
||||
\defun{alist-path-dispatcher}{handler-alist default-handler}{request-handler}
|
||||
\begin{desc}
|
||||
This procedure takes as arguments an alist mapping strings to path
|
||||
handlers, and a default request handler, and returns a handler that
|
||||
dispatches on its path argument. When the new request handler is
|
||||
applied to a path
|
||||
\begin{verbatim}
|
||||
("foo" "bar" "baz")
|
||||
\end{verbatim}
|
||||
it uses the
|
||||
first element of the path---\ex{foo}---to index into the
|
||||
alist. If it finds an associated request handler in the alist, it
|
||||
hands the request off to that handler, passing it the tail of the
|
||||
path, in this case
|
||||
\begin{verbatim}
|
||||
("bar" "baz")
|
||||
\end{verbatim}
|
||||
%
|
||||
On the other hand, if the path is
|
||||
empty, or the alist search does not yield a hit, we hand off to the
|
||||
default path handler, passing it the entire original path,
|
||||
\begin{verbatim}
|
||||
("foo" "bar" "baz")
|
||||
\end{verbatim}
|
||||
%
|
||||
This procedure is how you say: ``If the first element of the URL's
|
||||
path is `foo', do X; if it's `bar', do Y; otherwise, do Z.''
|
||||
The slash-delimited URI path structure implies an associated tree of
|
||||
names. The request-handler system and the alist dispatcher allow you to
|
||||
procedurally define the server's response to any arbitrary subtree
|
||||
of the path space.
|
||||
|
||||
Example: A typical top-level request handler is
|
||||
\begin{alltt}
|
||||
(define ph
|
||||
(alist-path-dispatcher
|
||||
`(("h" . ,(home-dir-handler "public\_html"))
|
||||
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin"))
|
||||
("seval" . ,seval-handler))
|
||||
(rooted-file-handler "/usr/local/etc/httpd/htdocs")))
|
||||
\end{alltt}
|
||||
|
||||
This means:
|
||||
\begin{itemize}
|
||||
\item If the path looks like \ex{("h"\ob{} "shivers"\ob{}
|
||||
"code"\ob{} "web.\ob{}tar.\ob{}gz")}, pass the path
|
||||
\ex{("shivers"\ob{} "code"\ob{} "web.\ob{}tar.\ob{}gz")} to a
|
||||
home-directory request handler.
|
||||
\item If the path looks like \ex{("cgi-\ob{}bin"\ob{} "calendar")},
|
||||
pass ("calendar") off to the CGI request handler.
|
||||
\item If the path looks like \ex{("seval"\ob{} \ldots)}, the tail
|
||||
of the path is passed off to the code-uploading \ex{seval} path
|
||||
handler.
|
||||
\item Otherwise, the whole path is passed to a rooted file handler,
|
||||
who will convert it into a filename, rooted at
|
||||
\ex{/usr/\ob{}lo\ob{}cal/\ob{}etc/\ob{}httpd/\ob{}htdocs},
|
||||
and serve that file.
|
||||
\end{itemize}
|
||||
\end{desc}
|
||||
|
||||
\subsection{Static Content Request Handlers}
|
||||
|
||||
The request handlers described in this section are for serving static
|
||||
content off directory trees in the file system. They live in the
|
||||
\ex{httpd-file-directory-handlers} structure.
|
||||
|
||||
The request handlers in this section eventually call an internal
|
||||
procedure named \ex{file\=serve} for serving files which implements a
|
||||
simple directory-generation service using the following rules:
|
||||
\begin{itemize}
|
||||
\item If the filename has the form of a directory (i.e., it ends with
|
||||
a slash), then \ex{file\=serve} actually looks for a file named
|
||||
\ex{index.html} in that directory.
|
||||
\item If the filename names a directory, but is not in directory form
|
||||
(i.e., it doesn't end in a slash, as in
|
||||
``\ex{/usr\ob{}in\ob{}clu\ob{}de}'' or ``\ex{/usr\ob{}raj}''),
|
||||
then \ex{file\=serve} sends back a ``301 moved permanently''
|
||||
message, redirecting the client to a slash-terminated version of the
|
||||
original URL. For example, the URL
|
||||
\ex{http://\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu/\ob{}~shi\ob{}vers}
|
||||
would be redirected to
|
||||
\ex{http://\ob{}clark.\ob{}lcs.\ob{}mit.\ob{}edu/\ob{}~shi\ob{}vers/}
|
||||
\item If the filename names a regular file, it is served to the
|
||||
client.
|
||||
\end{itemize}
|
||||
%
|
||||
The \ex{httpd-file-directory-handlers} all take an options value as an
|
||||
argument, similar to the options for \ex{httpd} itself.
|
||||
|
||||
The \var{options} argument can be constructed through a number of procedures
|
||||
with names of the form \texttt{with-\ldots}. Each of these procedures
|
||||
either creates a fresh options value or adds a configuration parameter
|
||||
to an old options argument. The configuration parameter value is
|
||||
always the first argument, the (old) options value the optional second
|
||||
one. Here they are:
|
||||
|
||||
\defun{with-file-name->content-type}{proc [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies a procedure for determining the MIME content type
|
||||
(``\ex{text/html},'' ``\ex{application/octet-stream}'' etc.)
|
||||
from a file name. \var{Proc} takes a file name as an argument and
|
||||
must return a string. (This is relevant in directory listings.) The default is a procedure able to handle the
|
||||
more common file extensions.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-file-name->content-encoding}{proc [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies a procedure for determining the MIME content encoding
|
||||
(if the file is compressed, gzipped, etc.) from a file name.
|
||||
(This is relevant in directory listings.)
|
||||
\var{Proc} takes a file name as an argument and must return two
|
||||
values: the equivalent, unencoded file name (i.e., without the
|
||||
trailing \ex{.Z} or \ex{.gz}) and a string representing the content
|
||||
encoding.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-file-name->icon-url}{proc [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies a procedure for determining the icon to be displayed
|
||||
next to a file name in a directory listing.
|
||||
\var{Proc} takes a file name as an argument and must return a URL
|
||||
for the corresponding icon or \sharpf.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-blank-icon-url}{file-name-or-\sharpf{} [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies a file name (or its absence) for the special icon
|
||||
that must be as wide as the icons returned by the previous procedure
|
||||
but that is blank.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-back-icon-url}{file-name-or-\sharpf{} [options]}{options}
|
||||
\begin{desc}
|
||||
This specifies a file name (or its absence) for the special icon
|
||||
that is displayed next to the ``parent directory'' link in directory
|
||||
listings.
|
||||
\end{desc}
|
||||
|
||||
\defun{with-unknown-icon-url}{file-name-or-\sharpf{}
|
||||
[options]}{options}
|
||||
\begin{desc}
|
||||
This specifies a file name (or its absence) for the special icon
|
||||
that is displayed next to the unknown entries in directory listings.
|
||||
\end{desc}
|
||||
|
||||
The \ex{make-file-directory-options} procedure eases the construction
|
||||
of the options argument:
|
||||
|
||||
\defun{make-file-directory-options}{transformer value \ldots}{options}
|
||||
\begin{desc}
|
||||
This constructs an options value from an argument list of parameter
|
||||
transformers and parameter values. The arguments come in pairs,
|
||||
each an option transformer from the list above, and a value for that
|
||||
parameter. \ex{Make-file-directory-options} returns the resulting
|
||||
options value.
|
||||
\end{desc}
|
||||
%
|
||||
Here are procedure for constructing static content request handlers:
|
||||
%
|
||||
\defun{rooted-file-handler}{root [options]}{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 \var{root}. 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 [options]}{request-handler}
|
||||
\begin{desc}
|
||||
Dito, but also serve directory indices for directories without
|
||||
\ex{index.html}.
|
||||
\end{desc}
|
||||
|
||||
\defun{home-dir-handler}{subdir [options]}{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 [options]}{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}
|
||||
|
||||
\section{SSL encryption with Apache}
|
||||
|
||||
Network traffic with a HTTP server is usually encrypted and protected
|
||||
from manipulation using the cryptographic algorithm provided by an
|
||||
implementation of the \textit{secure socket layer}, SSL for short.
|
||||
SUnet does not have support for SSL yet. However, an Apache
|
||||
web-server with SSL support can be configured as a proxy. In this
|
||||
setup the Apache web-server accepts encrypted requests and forwards
|
||||
them to a SUnet web-server running locally. This section describes
|
||||
how to set up Apache as an encrypting proxy, assuming the reader has
|
||||
basic knowledge about Apache and its configuration directives.
|
||||
|
||||
The following excerpt shows a minimalist SSL virtual host that
|
||||
forwards requests to a SUnet server.
|
||||
|
||||
\begin{alltt}
|
||||
<VirtualHost 134.2.12.82:443>
|
||||
DocumentRoot "/www/some-domain/htdocs"
|
||||
ServerName www.some-domain.de
|
||||
ServerAdmin admin@some-domain.de
|
||||
ErrorLog /www/some-domain/logs/error_log
|
||||
|
||||
ProxyRequests off
|
||||
ProxyPass / http://localhost:8080/
|
||||
ProxyPassReverse / http://localhost:8080/
|
||||
|
||||
SSLEngine on
|
||||
SSLRequireSSL
|
||||
|
||||
SSLCertificateFile /www/some-domain/cert/some-domain.cert
|
||||
SSLCertificateKeyFile /www/some-domain/cert/some-domain.key
|
||||
</VirtualHost>
|
||||
\end{alltt}
|
||||
|
||||
First, a virtual host is added to Apache's configuration file. This
|
||||
virtual host listens for incoming connections on port 443, which is
|
||||
the standard port for encrypted HTTP traffic. \texttt{SSLRequireSSL}
|
||||
ensures that server accepts encrypted connections only.
|
||||
|
||||
In terms of the Apache documentation, the web-server acts as a so
|
||||
called \textit{reverse proxy}. The option \texttt{ProxyRequests} has
|
||||
a misleading name. Setting this option to off does only turns off
|
||||
Apache's facility to act as a \textit{forward proxy} and has no effect
|
||||
on the configuration directives for reverse proxies. Actually,
|
||||
turning on \texttt{ProxyRequests} is dangerous, because this turns
|
||||
Apache into a proxy server that can be used from anywhere to access
|
||||
any site that is accessible to the Apache server.
|
||||
|
||||
In this setting, all requests get forwarded to a SUnet web-server
|
||||
which listens for incoming connections on localhost port 8080 only,
|
||||
thus, it is not reachable from a remote machine. Apache forwards all
|
||||
requests to the host and port specified by the \texttt{ProxyPass}
|
||||
directive. \texttt{ProxyPassReverse} specifies how
|
||||
\texttt{Location}-Header fields of HTTP redirect messages send by the
|
||||
SUNet server are translated.
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,135 +0,0 @@
|
|||
\chapter*{}
|
||||
|
||||
\thispagestyle{empty}
|
||||
|
||||
Of course, there is no Underground---or Untergrund, as those German
|
||||
new-age kids like to call the movement whose orders they
|
||||
have sworn to follow. The age we all remember---the cliff-green
|
||||
turbocharged convertibles, cigarettes hanging loose in the corners of
|
||||
our mouths, and those trigger-happy fingers always ready for the quick
|
||||
hack---is long gone.
|
||||
|
||||
In retrospect, it all seems like a candy-colored dream, and it may
|
||||
very well be---after all, there was never any proof that the
|
||||
Untergrund ever existed, and even if it did, we can be sure the
|
||||
obedient followers of the shadowy movement leaders have long burned
|
||||
the papers, subjected the hard drives and diskettes to interminable
|
||||
sessions of the junkyard magnet, and eradicated all shreds of
|
||||
memory from the brains of those who might have talked through long
|
||||
sessions of Tcl hacking to the sounds of Celine Dion records.
|
||||
|
||||
Yet there are those who still covet membership in that secret
|
||||
cult---to gain access to its powerful lore, to usurp invidious and
|
||||
powerful superiors, or simply to impress their girlfriends. For those
|
||||
lost souls of the modern age, I have a few words of advice:
|
||||
|
||||
It's not a question of ``membership''---silly merchandise and
|
||||
ridiculous certificates. If you are truly meant to be part of the
|
||||
Untergrund, you will know. \emph{The Untergrund will find you.}
|
||||
|
||||
Alas, probably not.
|
||||
|
||||
\medskip
|
||||
|
||||
\hfill April, 2003
|
||||
|
||||
\chapter{Overview}\label{sec:intro}
|
||||
|
||||
The Scheme Untergrund Networking Package (\textit{SUnet}, for short)
|
||||
is a collection of applications and libraries for Internet hacking in
|
||||
Scheme. It runs under Scsh, the Scheme shell. SUnet includes the
|
||||
following components:
|
||||
%
|
||||
\begin{description}
|
||||
\item[The SUnet Web server]
|
||||
This is a highly configurable HTTP 1.0 server in Scheme.
|
||||
The server is accompanied by 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}
|
||||
|
||||
The server also ships with a sophisticated interface for writing
|
||||
server-side Web applications called \textit{SUrflets}.
|
||||
|
||||
\item[The SUnet ftp server]
|
||||
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 libraries]
|
||||
These libraries lets you find out what time it is without paying for a
|
||||
Rolex.
|
||||
\item[DNS client library] This is a 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/resources/sunet.html}{here}{from
|
||||
\url{http://www.scsh.net/resources/sunet.html}}. To run the code, you need
|
||||
version 0.6.6 or later of \urlhd{http://www.scsh.net/}{scsh}{scsh from
|
||||
\url{http://www.scsh.net/}}.
|
||||
|
||||
\section{How to install SUnet}
|
||||
|
||||
Starting with version 2.1 SUnet conforms to the packaging proposal for
|
||||
scsh by Michel Schinz and needs Michel's installation library to
|
||||
install properly. For more information, please see
|
||||
\url{http://lamp.epfl.ch/~schinz/scsh_packages/}.
|
||||
|
||||
In short, this means that you can install SUnet by unpacking the SUnet
|
||||
tarball and issuing the following command in the created directory:
|
||||
|
||||
\begin{verbatim}
|
||||
scsh-install-pkg --prefix /path/to/your/package/root
|
||||
\end{verbatim}
|
||||
|
||||
See the file INSTALL for the generic installation instructions for
|
||||
scsh packages.
|
||||
|
||||
You need to install version 4.9 of the SSAX package to use SUnet. SSAX
|
||||
is available from \url{http://lamp.epfl.ch/~schinz/scsh_packages/}.
|
||||
|
||||
\section{How to use the packages}
|
||||
%
|
||||
After installation, you can use the \verb+-lel+ command-line option to
|
||||
load the package definitions. If you installed SUnet including
|
||||
SUrflets (the default), you need to load SSAX as well:
|
||||
%
|
||||
\begin{alltt}
|
||||
atari-2600[72] scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm
|
||||
Welcome to scsh 0.6.6 (King Conan)
|
||||
Type ,? for help.
|
||||
\end{alltt}
|
||||
%
|
||||
Now, all structures defined by SUnet and SSAX are available:
|
||||
%
|
||||
\begin{alltt}
|
||||
> ,open ftp
|
||||
Load structure ftp (y/n)? y
|
||||
[netrc netrc.scm]
|
||||
[ftp ftp.scm]
|
||||
> \textit{call library code}
|
||||
> ,exit
|
||||
atari-2600[73]
|
||||
\end{alltt}
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1 +0,0 @@
|
|||
../html
|
||||
|
|
@ -1,133 +0,0 @@
|
|||
% man.t2p
|
||||
% Dorai Sitaram
|
||||
% Feb 6, 2000
|
||||
|
||||
% This file contains the tex2page macros needed to process
|
||||
% the scsh LaTeX document scsh-n.n.n/doc/scsh-manual/man.tex.
|
||||
% Copy (or link) this file alongside man.tex and run
|
||||
%
|
||||
% tex2page man
|
||||
|
||||
\input css.t2p
|
||||
\htmlmathstyle{no-image}
|
||||
|
||||
\let\pagebreak\relax
|
||||
|
||||
\let\small\relax
|
||||
|
||||
%\let\PRIMtableofcontents\tableofcontents
|
||||
%\def\tableofcontents{\chapter*{Contents}\PRIMtableofcontents}
|
||||
|
||||
\def\subtitle#1{\def\savesubtitle{#1}}
|
||||
|
||||
\def\maketitle{
|
||||
\subject{\TIIPtitle}
|
||||
{\bf \hr}
|
||||
\rightline{\savesubtitle}
|
||||
\bigskip\bigskip
|
||||
\bigskip\bigskip
|
||||
{\bf\TIIPauthor}
|
||||
{\bf\hr}
|
||||
}
|
||||
|
||||
\let\PRIMdocument\document
|
||||
|
||||
\def\document{\PRIMdocument
|
||||
|
||||
\let\ttchars\relax
|
||||
\let\ttt\tt
|
||||
|
||||
%\def\~{\rawhtml~\endrawhtml}
|
||||
\def\~{\char`\~}
|
||||
\def\cd#1{{\tt\def\\{\char`\\}\defcsactive\${\char`\$}\defcsactive\~{\char`\~}\defcsactive\&{\char`\&}#1}}
|
||||
\def\cddollar{\undefcsactive\$}
|
||||
\def\cdmath{\undefcsactive\$}
|
||||
\def\codeallowbreaks{\relax}
|
||||
\def\defvarx#1#2{\index{#1}\leftline{{\tt #1} \qquad #2}}
|
||||
|
||||
\let\PRIMflushright\flushright
|
||||
|
||||
\def\flushright{\PRIMflushright\TIIPtabularborder=0 }
|
||||
|
||||
\let\PRIMfigure\figure
|
||||
\let\PRIMendfigure\endfigure
|
||||
|
||||
\def\figure{\par\hrule\PRIMfigure}
|
||||
\def\endfigure{\PRIMendfigure\hrule\par}
|
||||
|
||||
\let\PRIMtable\table
|
||||
\let\PRIMendtable\endtable
|
||||
|
||||
\def\table{\par\hrule\PRIMtable}
|
||||
\def\endtable{\PRIMendtable\hrule\par}
|
||||
|
||||
\imgdef\vdots{\bf.\par.\par.}
|
||||
|
||||
%\evalh{
|
||||
%
|
||||
%(define all-blanks?
|
||||
% (lambda (s)
|
||||
% (andmap
|
||||
% char-whitespace?
|
||||
% (string->list s))))
|
||||
%
|
||||
%}
|
||||
%
|
||||
%
|
||||
%\def\spaceifnotempty{\evalh{
|
||||
%
|
||||
%(let ((x (ungroup (get-token))))
|
||||
% (unless (all-blanks? x)
|
||||
% (emit #\space)))
|
||||
%
|
||||
%}}
|
||||
|
||||
\def\spaceifnotempty#1{%
|
||||
\def\TEMP{#1}%
|
||||
\ifx\TEMP\empty\else\ \fi}
|
||||
|
||||
\def\dfnix#1#2#3#4{\leftline{{\tt(#1\spaceifnotempty{#2}{\it#2})} \quad $\longrightarrow$ \quad {\it #3} \qquad (#4)} \index}
|
||||
|
||||
%\def\ex#1{{\tt #1}}
|
||||
%\let\ex\texttt
|
||||
\def\l#1{lambda (#1)}
|
||||
\def\lx#1{lambda {#1}}
|
||||
%\def\notenum#1{}
|
||||
%\def\project#1{}
|
||||
%\def\var#1{{\it #1\/}}
|
||||
%\let\var\textit
|
||||
%\def\vari#1#2{\mbox{{\it #1\/}\undefcsactive\$$_{#2}$}}
|
||||
%\def\vari#1#2{\textit{#1}$_{#2}$}
|
||||
|
||||
\renewenvironment{boxedfigure}{\def\srecomment#1{\\#1\\}%
|
||||
\begin{figure}\pagestyle}{\end{figure}}
|
||||
|
||||
\newenvironment{centercode}{\begin{code}}{\end{code}}
|
||||
|
||||
\def\setupcode{\tt%
|
||||
\def\\{\char`\\}%
|
||||
\defcsactive\${\$}%
|
||||
\def\evalto{==> }%
|
||||
\defcsactive\%{\%}\obeywhitespace}
|
||||
|
||||
\newenvironment{code}{\begin{quote}\setupcode\GOBBLEOPTARG}
|
||||
{\end{quote}}
|
||||
|
||||
\newenvironment{codebox}{\begin{tableplain}\bgroup\setupcode\GOBBLEOPTARG}
|
||||
{\egroup\end{tableplain}}
|
||||
|
||||
\renewenvironment{desc}{\begin{quote}}{\end{quote}}
|
||||
|
||||
\renewenvironment{exampletable}{%
|
||||
\def\header#1{\\\leftline{#1}\\}%
|
||||
\def\splitline#1#2{\\\leftline{#1}\\\leftline{#2}}%
|
||||
\begin{tabular}{}}{\end{tabular}}
|
||||
|
||||
\newenvironment{tightcode}{\begin{code}}{\end{code}}
|
||||
\renewenvironment{widecode}{\begin{code}}{\end{code}}
|
||||
|
||||
\renewenvironment{inset}{\begin{quote}}{\end{quote}}
|
||||
\renewenvironment{leftinset}{\begin{quote}}{\end{quote}}
|
||||
\renewenvironment{tightinset}{\begin{quote}}{\end{quote}}
|
||||
\renewenvironment{tightleftinset}{\begin{quote}}{\end{quote}}
|
||||
}
|
||||
|
|
@ -1,79 +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}
|
||||
\usepackage{tabularx,theorem,ulem,float,afterpage} % need url
|
||||
\normalem % usually, don't use ulem
|
||||
|
||||
\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.1},
|
||||
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.1},
|
||||
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.1}
|
||||
\author{Dr. S\raisebox{1ex}{2}, Martin Gasbichler, Eric Marsden, Andreas Bernauer}
|
||||
\date{October 2004}
|
||||
|
||||
\mainmatter
|
||||
\maketitle
|
||||
|
||||
\tableofcontents
|
||||
|
||||
\include{intro}
|
||||
\include{httpd}
|
||||
\include{uri}
|
||||
\include{url}
|
||||
\include{cgi-script}
|
||||
\include{surflets}
|
||||
\include{ftpd}
|
||||
\include{ftp}
|
||||
\include{netrc}
|
||||
\include{rfc822}
|
||||
\include{nettime}
|
||||
\include{smtp}
|
||||
\include{pop3}
|
||||
\include{dns}
|
||||
|
||||
\backmatter
|
||||
\printindex
|
||||
|
||||
\end{document}
|
||||
|
|
@ -1,76 +0,0 @@
|
|||
% This is the title page style stolen from the Texinfo design,
|
||||
% and expressed as a LaTeX style option. It is useful for manuals.
|
||||
%
|
||||
% Note that I play some *really* revolting games here to override
|
||||
% the vertical and horizontal margins temporarily for the title page.
|
||||
% The layout assumes you have 8.5" x 11" paper. You'd have to redo this
|
||||
% for A4 or another size.
|
||||
% -Olin 7/94
|
||||
|
||||
|
||||
% Fonts for title page:
|
||||
\DeclareFixedFont{\titlefont}%
|
||||
{\encodingdefault}{\familydefault}{bx}{\shapedefault}{20.5pt}
|
||||
\DeclareFixedFont{\authorfnt}%
|
||||
{\encodingdefault}{\familydefault}{bx}{\shapedefault}{14.4pt}
|
||||
\DeclareFixedFont{\subtitlefnt}%
|
||||
{\encodingdefault}{\familydefault}{m}{\shapedefault}{11}
|
||||
|
||||
%\def\authorrm{\normalfont\selectfont\fontseries{bx}\fontsize{14.4}{14.4}}
|
||||
%\def\subtitlefnt{\normalfont\selectfont\fontsize{11}{11}}
|
||||
|
||||
\newskip\titlepagetopglue \titlepagetopglue = 2.5in
|
||||
|
||||
|
||||
\newlength{\widewidth}
|
||||
\setlength{\widewidth}{6.5in}
|
||||
\newlength{\negwidemargin}
|
||||
\setlength{\negwidemargin}{-\oddsidemargin} % Reset the margin
|
||||
\addtolength{\negwidemargin}{-1in} % to edge of page
|
||||
\addtolength{\negwidemargin}{1in} % Then move right one inch.
|
||||
|
||||
%\def\wideline#1{\hbox to 0pt{\hspace\negwidemargin\hbox to\widewidth{#1}}}
|
||||
\def\wideline#1{\hbox{\makebox[0pt][l]{\hspace\negwidemargin\hbox to\widewidth{#1}}}}
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
\def\maketitle{\begin{titlepage}
|
||||
\thispagestyle{empty}
|
||||
\let\footnotesize\small \let\footnoterule\relax
|
||||
\null
|
||||
\parindent=0pt
|
||||
\def\subtitlefont{\normalbaselineskip = 13pt \normalbaselines \subtitlefnt}%
|
||||
\def\authorfont{\normalbaselineskip = 16pt \normalbaselines \authorfnt}%
|
||||
%
|
||||
% Leave some space at the very top of the page.
|
||||
\vspace*{-1in}\vspace*{-\topmargin}\vspace*{-\headheight}\vspace*{-\headsep}
|
||||
\vglue\titlepagetopglue
|
||||
%
|
||||
\wideline{\titlefont \@title \hfill} % title
|
||||
% \vskip4pt
|
||||
\vskip -0.3\baselineskip
|
||||
\wideline{\leaders\hrule height 4pt\hfill}
|
||||
\wideline{\hfill\subtitlefont\begin{tabular}[t]{@{}r@{}}\@subtitle%
|
||||
\\\@date%
|
||||
\end{tabular}} % subtitle
|
||||
%
|
||||
% author
|
||||
\vskip 0pt plus 1filll
|
||||
\wideline{\authorfont \begin{tabular}[t]{@{}c@{}}\@author
|
||||
\end{tabular}\hfill}
|
||||
%
|
||||
% \vskip4pt
|
||||
\vskip -0.3\baselineskip
|
||||
\wideline{\leaders\hrule height 2pt\hfill}
|
||||
|
||||
% This weirdness puts the bottom line 2.75 in from the bottom of
|
||||
% an 11in page.
|
||||
\vskip \textheight \vskip \headsep \vskip \headheight
|
||||
\vskip \topmargin \vskip 1in \vskip -11in \vskip 2.75in
|
||||
|
||||
\gdef\@author{}\gdef\@title{}\gdef\@subtitle{}\let\maketitle\relax
|
||||
\end{titlepage}
|
||||
\setcounter{page}{2}
|
||||
}
|
||||
|
||||
\def\subtitle#1{\gdef\@subtitle{#1}}
|
||||
\def\@subtitle{}
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
%&latex -*- latex -*-
|
||||
% Implement the \frontmatter, \mainmatter, and \backmatter macros,
|
||||
% so I can use them in reports, not just books.
|
||||
|
||||
\newif\if@mainmatter \@mainmattertrue
|
||||
|
||||
\newcommand\frontmatter{%
|
||||
\cleardoublepage\@mainmatterfalse\pagenumbering{roman}}
|
||||
|
||||
\newcommand\mainmatter{%
|
||||
\cleardoublepage\@mainmattertrue%
|
||||
\pagenumbering{arabic}\setcounter{page}{1}}
|
||||
|
||||
\newcommand\backmatter{%
|
||||
\if@openright\cleardoublepage\else\clearpage\fi%
|
||||
\@mainmatterfalse}
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
%&latex -*- latex -*-
|
||||
\if@twoside
|
||||
\oddsidemargin 44pt
|
||||
\evensidemargin 82pt
|
||||
\marginparwidth 107pt
|
||||
\else
|
||||
\oddsidemargin 63pt
|
||||
\evensidemargin 63pt
|
||||
\marginparwidth 90pt
|
||||
\fi
|
||||
\marginparsep 11pt
|
||||
|
||||
\topmargin 27pt
|
||||
\headheight 12pt
|
||||
\headsep 25pt
|
||||
\topskip = 10pt
|
||||
\footskip 30pt
|
||||
|
||||
\textheight = 43\baselineskip
|
||||
\advance\textheight by \topskip
|
||||
\textwidth 345pt
|
||||
\endinput
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
\chapter{Parsing Netrc Files}\label{cha:netrc}
|
||||
%
|
||||
The \ex{netrc} structures provides procedures to parse authentication
|
||||
information contained in \ex{~/.netrc}.
|
||||
|
||||
On Unix systems the netrc file may contain information allowing
|
||||
automatic login to remote hosts. The format of the file is defined in
|
||||
the \ex{ftp(1)} manual page. Example lines are
|
||||
%
|
||||
\begin{verbatim}
|
||||
machine ondine.cict.fr login marsden password secret
|
||||
default login anonymous password user@site
|
||||
\end{verbatim}
|
||||
%
|
||||
The netrc file should be protected by appropriate permissions, and
|
||||
(like \ex{/usr/bin/ftp}) this library will refuse to read the file if it is
|
||||
badly protected. (unlike \ex{ftp} this library will always refuse
|
||||
to read the file----\ex{ftp} refuses it only if the password is
|
||||
given for a non-default account). Appropriate permissions are set if
|
||||
only the user has permissions on the file.
|
||||
|
||||
\defun{netrc-machine-entry}{host accept-default? [file-name]}{netrc-entry-or-\sharpf}
|
||||
\begin{desc}
|
||||
This procedure looks for the entry related to given host in the
|
||||
user's netrc file. The host is specified in \var{host}.
|
||||
\var{Accept-default?} specifies whether \ex{netrc-machine-entry}
|
||||
should fall back to the default entry if there is no macht for
|
||||
\var{host} in the netrc file. If specified, \var{file-name}
|
||||
specifies an alternate file name for the netrc data. It defaults to
|
||||
\ex{.netrc} in the current user's home directory.
|
||||
|
||||
\ex{Netrc-machine-entry} returns a netrc entry (see below) if it was
|
||||
able to find the requested information; if not, it returns \sharpf.
|
||||
|
||||
If the netrc file had inappropriate permissions, \ex{netrc-machine-entry}
|
||||
raises an error.
|
||||
\end{desc}
|
||||
|
||||
\defun{netrc-entry?}{thing}{boolean}
|
||||
\defunx{netrc-entry-machine}{netrc-entry}{string}
|
||||
\defunx{netrc-entry-login}{netrc-entry}{string-or-\sharpf}
|
||||
\defunx{netrc-entry-password}{netrc-entry}{string-or-\sharpf}
|
||||
\defunx{netrc-entry-account}{netrc-entry}{string-or-\sharpf}
|
||||
\begin{desc}
|
||||
\ex{Netrc-entry?} is the predicate for netrc entries. The other
|
||||
procedures are selectors for netrc entries as returned by
|
||||
\ex{netrc-machine-entry}. They return \sharpf{} if the netrc file
|
||||
didn't contain a binding for the corresponding field.
|
||||
\end{desc}
|
||||
|
||||
\defun{netrc-macro-definitions}{[file-name]}{alist}
|
||||
\begin{desc}
|
||||
This returns the macro definitions from the netrc files, represented
|
||||
as an alist mapping macro names---represented as strings---to
|
||||
definitions---represented as lists of strings.
|
||||
\end{desc}
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
\chapter{Time and Daytime}\label{cha:ntp}
|
||||
|
||||
Many Unix hosts provide a RFC~867 Daytime service which sends the
|
||||
current date and time as a human-readable character string. The
|
||||
daytime service is typically served on port 13 as both TCP and UDP.
|
||||
|
||||
The RFC~868 Time protocol provides a site-independent, machine
|
||||
readable date and time. The Time service is typically served
|
||||
on port 37 as TCP and UDP. The idea is that you can confirm your
|
||||
system's idea of the time by polling several independent sites on the
|
||||
network.
|
||||
|
||||
\section{Daytime}
|
||||
|
||||
The \ex{rfc867} structure contains an interface to Daytime protocol.
|
||||
|
||||
\defun{rfc867-daytime/tcp}{host}{string}
|
||||
\defunx{rfc867-daytime/udp}{host [timeout-or-\sharpf]}{string-or-\sharpf}
|
||||
\begin{desc}
|
||||
These procedures asks \var{host} about the current daytime and
|
||||
return the host's answer (e.g., ``Thursday, April 4,
|
||||
2'').
|
||||
|
||||
\ex{Rfc867-daytime/tcp} uses the TCP variant of the protocol.
|
||||
\ex{Rfc867-daytime/udp} uses UDP and sends a single request to the
|
||||
server. It allows the specification of an optional timeout; if not
|
||||
specified or \sharpf{}, \ex{Rfc867-daytime/udp} will wait
|
||||
indefinitely for an answer. If the answer from the server doesn't
|
||||
arrive within the specified time, \ex{rfc867-daytime/udp} returns
|
||||
\sharpf.
|
||||
\end{desc}
|
||||
|
||||
\section{Time}
|
||||
|
||||
The \ex{rfc868} structure contains an interface to the Time protocol.
|
||||
|
||||
\defun{rfc868-time/tcp}{host}{string}
|
||||
\defunx{rfc868-time/udp}{host [timeout-or-\sharpf]}{string-or-\sharpf}
|
||||
\begin{desc}
|
||||
These procedures asks \var{host} about the current time and return
|
||||
the host's answer. This is the number of second since 1970, just as
|
||||
with scsh's \texttt{time} procedure.
|
||||
|
||||
\ex{rfc868-time/tcp} uses the TCP variant of the protocol.
|
||||
\ex{rfc868-time/udp} uses UDP and sends a single request to the
|
||||
server. It allows the specification of an optional timeout; if not
|
||||
specified or \sharpf{}, \ex{rfc868-time/udp} will wait
|
||||
indefinitely for an answer. If the answer from the server doesn't
|
||||
arrive within the specified time, \ex{rfc868-time/udp} returns
|
||||
\sharpf.
|
||||
\end{desc}
|
||||
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
\newif\ifpdf
|
||||
\ifx\pdfoutput\undefined
|
||||
\pdffalse % we are not running PDFLaTeX
|
||||
\else
|
||||
\pdfoutput=1 % we are running PDFLaTeX
|
||||
\pdftrue
|
||||
\fi
|
||||
% Then use your new variable \ifpdf
|
||||
% \ifpdf
|
||||
% \usepackage[pdftex]{graphicx}
|
||||
% \pdfcompresslevel=9
|
||||
% \else
|
||||
% \usepackage{graphicx}
|
||||
% \fi
|
||||
|
|
@ -1,99 +0,0 @@
|
|||
\chapter{POP3 Client}\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}
|
||||
|
||||
\defun{pop3-quit}{connection}{undefined}
|
||||
\begin{desc}
|
||||
This closes the connection with the mailhost.
|
||||
\end{desc}
|
||||
|
||||
\defun{pop3-error?}{thing}{boolean}
|
||||
\begin{desc}
|
||||
This returns \sharpt{} if \var{thing} is a \ex{pop3-error} object,
|
||||
otherwise \sharpf.
|
||||
\end{desc}
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,107 +0,0 @@
|
|||
\chapter{RFC~822 Library}\label{cha:rfc822}
|
||||
%
|
||||
The \ex{rfc822} structure provides rudimentary support for parsing
|
||||
headers according to RFC~822 \textit{Standard for the format of ARPA
|
||||
Internet text messages}. These headers show up in SMTP messages,
|
||||
HTTP headers, etc.
|
||||
|
||||
An RFC~822 header field consists of a \textit{field name} and a
|
||||
\textit{field body}, like so:
|
||||
%
|
||||
\begin{verbatim}
|
||||
Subject: RFC 822 can format itself in the ARPA
|
||||
\end{verbatim}
|
||||
%
|
||||
Here, the field name is `\ex{Subject}', and the field name is `\ex{
|
||||
RFC 822 can format itself in the ARPA}' (note the leading space).
|
||||
The field body can be spread over several lines:
|
||||
%
|
||||
\begin{verbatim}
|
||||
Subject: RFC 822 can format itself
|
||||
in the ARPA
|
||||
\end{verbatim}
|
||||
%
|
||||
In this case, RFC~822 specifies that the meaning of the field body is
|
||||
actually all the lines of the body concatenated, without the
|
||||
intervening line breaks.
|
||||
|
||||
The \ex{rfc822} structure provides two sets of parsing
|
||||
procedures---one represents field bodies in the RFC-822-specified
|
||||
meaning, as a single string, the other (with \ex{-with-line-breaks}
|
||||
appended to the names) reflects the line breaks and represents the
|
||||
bodies as a list of string, one for each line. The latter set only
|
||||
marginally useful---mainly for code that needs to output headers in
|
||||
the same form as they were originally provided.
|
||||
|
||||
\defun{read-rfc822-field}{[port] [read-line]}{name body}
|
||||
\defun{read-rfc822-field-with-line-breaks}{[port] [read-line]}{name body-lines}
|
||||
\begin{desc}
|
||||
|
||||
Read one field from the port, and return two values:
|
||||
%
|
||||
\begin{description}
|
||||
\item[\var{name}] This is a symbol describing the field
|
||||
name, such as \ex{subject} or \ex{to}. The symbol consists of all
|
||||
lower-case letters.\footnote{In fact, it \ex{read-rfc822-field}
|
||||
uses the preferred case for symbols of the underlying Scheme
|
||||
implementation which, in the case of scsh, happens to be lower-case.}
|
||||
\item[\var{body} or \var{body-lines}] This is the field body.
|
||||
\var{Body} is a single string, \var{body-lines} is a list of
|
||||
strings, one for each line of the body. In each case,
|
||||
the terminating \ex{cr}/\ex{lf}'s (but nothing else) are
|
||||
trimmed from each string.
|
||||
\end{description}
|
||||
%
|
||||
When there are no more fields---EOF or a blank line has terminated
|
||||
the header section---then both procedures returns [\sharpf\
|
||||
\sharpf].
|
||||
|
||||
\var{Port} is an optional input port to read from---it defaults to
|
||||
the value of \ex{(current-input-port)}.
|
||||
|
||||
\var{Read-line} is an optional parameter specifying a procedure of
|
||||
one argument (the input port) used to read the raw header lines.
|
||||
The default used by these procedures terminates lines with
|
||||
either \ex{cr}/\ex{lf} or just \ex{lf}, and it trims the terminator
|
||||
from the line. This procedure should trim the terminator of the
|
||||
line, so an empty line is returned as an empty string.
|
||||
|
||||
The procedure raises an error if the syntax of the read field (the
|
||||
line returned by the read-line-function) is illegal according to
|
||||
RFC~822.
|
||||
\end{desc}
|
||||
|
||||
\defun{read-rfc822-headers} {[port] [read-line]} {alist}
|
||||
\defunx{read-rfc822-headers-with-line-breaks} {[port] [read-line]} {alist}
|
||||
\begin{desc}
|
||||
This procedure reads in and parses a section of text that looks like
|
||||
the header portion of an RFC~822 message. It returns an association
|
||||
list mapping field names (a symbol such as \ex{date} or \ex{subject}) to
|
||||
field bodies. The representation of the field bodies is as with
|
||||
\ex{read-rfc822-field} and \ex{read-rfc822-field-with-line-breaks}.
|
||||
|
||||
These procedures preserve the order of the header fields. Note that
|
||||
several header fields might share the same field name---in that
|
||||
case, the returned alist will contain several entries with the same
|
||||
\ex{car}.
|
||||
|
||||
\var{Port} and \var{read-line} are as with \ex{read-rfc822-field}
|
||||
and \ex{read-rfc822-field-with-line-breaks}.
|
||||
\end{desc}
|
||||
|
||||
\defun{rfc822-time->string}{time}{string}
|
||||
\begin{desc}
|
||||
This formats a time value (as returned by scsh's \ex{time})
|
||||
according to the requirements of the RFC~822 \ex{Date} header
|
||||
field. The format looks like this:
|
||||
%
|
||||
\begin{verbatim}
|
||||
Sun, 06 Nov 1994 08:49:37 GMT
|
||||
\end{verbatim}
|
||||
\end{desc}
|
||||
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
\section{Section-Title}
|
||||
%
|
||||
\begin{description}
|
||||
\item[Used files:]
|
||||
\item[Name of the package:]
|
||||
\end{description}
|
||||
%
|
||||
Not implemented yet.
|
||||
|
|
@ -1,123 +0,0 @@
|
|||
\chapter{SMTP Client}\label{cha:smtp}
|
||||
%
|
||||
The \ex{smtp} structure provides an client library for the Simple Mail
|
||||
Transfer Protocol, commonly used for sending email on the Internet.
|
||||
This library provides a simple wrapper for sending complete emails as
|
||||
well as procedures for composing custom SMTP transactions.
|
||||
|
||||
Some of the procedures described here return an SMTP reply code. For
|
||||
details, see RFC~821.
|
||||
|
||||
\defun{smtp-send-mail}{from to-list headers body [host]}{undefined}
|
||||
\defunx{smtp-error?}{thing}{boolean}
|
||||
\defunx{smtp-recipients-rejected-error?}{thing}{boolean}
|
||||
\begin{desc}
|
||||
This emails message \var{body} with headers \var{headers} to
|
||||
recipients in list \var{to-list}, using a sender address \var{from}.
|
||||
The email is handed off to the SMTP server running on \var{host};
|
||||
default is the local host. \var{Body} is either a list of strings
|
||||
representing the lines of the message body or an input port which is
|
||||
exhausted to determine the message body. \var{Headers} is an
|
||||
association lists, mapping symbols representing RFC~822 field names
|
||||
to strings representing field bodies.
|
||||
|
||||
If some transaction-related error happens, \ex{smtp-send-mail}
|
||||
signals an \ex{smtp-error} condition with predicate
|
||||
\ex{smtp-error?}. More specifically, it raises an
|
||||
\ex{smtp-recipients-rejected-error} (a subtype of \ex{smtp-error})
|
||||
if some recipients were rejected. For \ex{smtp-error}, the
|
||||
arguments to the \ex{signal} call are the error code and the error
|
||||
message, represented as a list of lines. For
|
||||
\ex{smtp-recipients-rejected-error}, the arguments are reply code
|
||||
700 and an association list whose elements are of the form
|
||||
\ex{(\var{loser-recipient} \var{code} . \var{text})}---that is, for
|
||||
each recipient refused by the server, you get the error data sent
|
||||
back for that guy. The success check is \ex{(< code 400)}.
|
||||
\end{desc}
|
||||
|
||||
\defun{smtp-expand}{name host}{code text}
|
||||
\defunx{smtp-verify}{name host}{code text}
|
||||
\defunx{smtp-get-help}{host [details]}{code text-list}
|
||||
\begin{desc}
|
||||
These three are simple queries of the server as stated in the
|
||||
RFC~821: \ex{smtp-expann} asks the server to confirm that the
|
||||
argument identifies a mailing list, and if so, to return the
|
||||
membership of that list. The full name of the users (if known) and
|
||||
the fully specified mailboxes are returned in a multiline reply.
|
||||
\ex{Smtp-verify} asks the receiver to confirm that the argument
|
||||
identifies a user. If it is a user name, the full name of the user
|
||||
(if known) and the fully specified mailbox are returned.
|
||||
\ex{Smtp-get-help} causes the server to send helpful information.
|
||||
The command may take an argument (\var{details}) (e.g., any command
|
||||
name) and return more specific information as a response.
|
||||
\end{desc}
|
||||
|
||||
\defun{smtp-connect}{host [port]}{smtp-connection}
|
||||
\begin{desc}
|
||||
\ex{Smtp-connect} returns an SMTP connection value that represents
|
||||
a connection to the SMTP server.
|
||||
\end{desc}
|
||||
|
||||
\defun{smtp-transactions}{smtp-connection transaction1 ...}{code text-list}
|
||||
\defunx{smtp-transactions/no-close}{smtp-connection transaction1 ...}{code text-list}
|
||||
\begin{desc}
|
||||
These procedures make it easy to do simple sequences of SMTP
|
||||
commands. \var{Smtp-connection} must be an SMTP connection as
|
||||
returned by \ex{smtp-connect}. The \var{transaction} arguments must
|
||||
be transactions as returned by the procedures below.
|
||||
\ex{Smtp-transactions} and \ex{smtp-transactions/no-close} execute
|
||||
the transactions specified by the arguments.
|
||||
|
||||
For each transaction,
|
||||
\begin{itemize}
|
||||
\item If the transaction's reply code is 221 or 421 (meaning the socket has
|
||||
been closed), then the transaction sequence is aborted, and
|
||||
\ex{smtp-transactions}/\ex{smtp-transactions/no-close} return the
|
||||
reply code and text from that transaction.
|
||||
\item If the reply code is an error code (in the four- or five-hundred range),
|
||||
the transaction sequence is aborted, and the fatal transaction's code
|
||||
and text values are returned. \ex{Smtp-transactions} will additionally
|
||||
close the socket for you; \ex{smtp-transactions/no-close} will not.
|
||||
\item If the transaction is the last in the transaction sequence,
|
||||
its reply code and text are returned.
|
||||
\item Otherwise, we throw away the current reply code and text, and
|
||||
proceed to the next transaction.
|
||||
\end{itemize}
|
||||
%
|
||||
\ex{Smtp-transactions} closes the socket after the transaction. (The
|
||||
\ex{smtp-quit} transaction, when executed, also closes the transaction.)
|
||||
|
||||
If the socket should be kept open in the case of an abort, use
|
||||
\ex{Smtp-transactions/no-close}.
|
||||
\end{desc}
|
||||
|
||||
\defunx{smtp-helo}{local-host-name}{smtp-transaction}
|
||||
\defunx{smtp-mail}{sender-address}{smtp-transaction}
|
||||
\defunx{smtp-rcpt}{destination-address}{smtp-transaction}
|
||||
\defunx{smtp-data}{socket message}{smtp-transaction}
|
||||
\defunx{smtp-send}{sender-address}{smtp-transaction}
|
||||
\defunx{smtp-soml}{sender-address}{smtp-transaction}
|
||||
\defunx{smtp-saml}{sender-address}{smtp-transaction}
|
||||
\defvarx{smtp-rset}{smtp-transaction}
|
||||
\defunx{smtp-vrfy}{user}{smtp-transaction}
|
||||
\defunx{smtp-expn}{user}{smtp-transaction}
|
||||
\defunx{smtp-help}{details}{smtp-transaction}
|
||||
\defvarx{smtp-noop}{smtp-transaction}
|
||||
\defvarx{smtp-quit}{smtp-transaction}
|
||||
\defvarx{smtp-turn}{smtp-transaction}
|
||||
\begin{desc}
|
||||
These transactions represent the commands of the SMTP protocol for
|
||||
use in \ex{smtp-transactions} and \ex{smtp-transactions/no-close},
|
||||
i.e.\ they send the corresponding command along with the argument(s),
|
||||
if any. For details, consult RFC~821.
|
||||
|
||||
The \ex{smtp-quit} transaction, in addition to sending a \ex{QUIT}
|
||||
command to the SMTP server, also closes the socket of its SMTP
|
||||
connection.
|
||||
\end{desc}
|
||||
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -1,14 +0,0 @@
|
|||
\chapter{SUrflet server}
|
||||
|
||||
\newcommand{\typew}[1]{\texttt{#1}}
|
||||
|
||||
The \surflet server enables you to write server side scripted web
|
||||
programs in Scheme.
|
||||
%Currently, there is only the howto available.
|
||||
%The complete API is supposed to come soon.
|
||||
There are lots of example files in
|
||||
\typew{scheme/httpd/surflet/webserver/root/surflets} from which you
|
||||
can copy freely.
|
||||
|
||||
\input{surflethowto}
|
||||
\input{surfletapi}
|
||||
|
|
@ -1,166 +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. RFC 2396 defines this set as all characters which
|
||||
are neither letters, nor digits, nor one of the following characters:
|
||||
\verb|-|, \verb|_|, \verb|.|, \verb|!|, %$
|
||||
\verb|~|, \verb|*|, \verb|'|, \verb|(|, \verb|)|.
|
||||
\end{desc}
|
||||
|
||||
\defun{escape-uri} {string [escaped-chars]} {string}
|
||||
\begin{desc}
|
||||
This procedure escapes characters of \var{string} that are in
|
||||
\var{escaped\=chars}. \var{Escaped\=chars} defaults to
|
||||
\ex{uri\=escaped\=chars}.
|
||||
\end{desc}
|
||||
%
|
||||
Be careful with using this procedure to chunks of text with
|
||||
syntactically meaningful reserved characters (e.g., paths with URI
|
||||
slashes or colons)---they'll be escaped, and lose their special
|
||||
meaning. E.g.\ it would be a mistake to apply \ex{escape-uri} to
|
||||
\begin{verbatim}
|
||||
//lcs.mit.edu:8001/foo/bar.html
|
||||
\end{verbatim}
|
||||
%
|
||||
because the sla\-shes and co\-lons would be escaped.
|
||||
|
||||
\defun{split-uri}{uri start end} {list}
|
||||
\begin{desc}
|
||||
This procedure splits \var{uri} at slashes. Only the substring given
|
||||
with \var{start} (inclusive) and \var{end} (exclusive) as indices is
|
||||
considered. \var{start} and $\var{end} - 1$ have to be within the
|
||||
range of \var{uri}. Otherwise an \ex{index-out-of-range} exception
|
||||
will be raised.
|
||||
|
||||
Example: \codex{(split-uri "foo/bar/colon" 4 11)} returns
|
||||
\codex{("bar" "col")}
|
||||
\end{desc}
|
||||
|
||||
\defun{uri-path->uri}{path}{string}
|
||||
\begin{desc}
|
||||
This procedure generates a path out of a URI path list by inserting
|
||||
slashes between the elements of \var{plist}.
|
||||
\end{desc}
|
||||
%
|
||||
If you want to use the resulting string for further operation, you
|
||||
should escape the elements of \var{plist} in case they contain
|
||||
slashes, like so:
|
||||
%
|
||||
\begin{verbatim}
|
||||
(uri-path->uri (map escape-uri pathlist))
|
||||
\end{verbatim}
|
||||
|
||||
\defun{simplify-uri-path}{path}{list}
|
||||
\begin{desc}
|
||||
This procedure simplifies a URI path. It removes \verb|"."| and
|
||||
\verb|"/.."| entries from path, and removes parts before a root.
|
||||
The result is a list, or \sharpf{} if the path tries to back up past
|
||||
root.
|
||||
\end{desc}
|
||||
%
|
||||
According to RFC~2396, relative paths are considered not to start with
|
||||
\verb|/|. They are appended to a base URL path and then simplified.
|
||||
So before you start to simplify a URL try to find out if it is a
|
||||
relative path (i.e. it does not start with a \verb|/|).
|
||||
|
||||
Examples:
|
||||
%
|
||||
\begin{alltt}
|
||||
(simplify-uri-path (split-uri "/foo/bar/baz/.." 0 15))
|
||||
\(\Rightarrow\) ("" "foo" "bar")
|
||||
|
||||
(simplify-uri-path (split-uri "foo/bar/baz/../../.." 0 20))
|
||||
\(\Rightarrow\) ()
|
||||
|
||||
(simplify-uri-path (split-uri "/foo/../.." 0 10))
|
||||
\(\Rightarrow\) #f
|
||||
|
||||
(simplify-uri-path (split-uri "foo/bar//" 0 9))
|
||||
\(\Rightarrow\) ("")
|
||||
|
||||
(simplify-uri-path (split-uri "foo/bar/" 0 8))
|
||||
\(\Rightarrow\) ("")
|
||||
|
||||
(simplify-uri-path (split-uri "/foo/bar//baz/../.." 0 19))
|
||||
\(\Rightarrow\) #f
|
||||
\end{alltt}
|
||||
|
||||
|
||||
%%% Local Variables:
|
||||
%%% mode: latex
|
||||
%%% TeX-master: "man"
|
||||
%%% End:
|
||||
|
|
@ -1,113 +0,0 @@
|
|||
\chapter{Parsing and Processing URLs}\label{cha:url}
|
||||
%
|
||||
The \ex{url} structure 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-fragment-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->uri (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:
|
||||
26
pkg-def.scm
26
pkg-def.scm
|
|
@ -1,26 +0,0 @@
|
|||
(define-package "sunet" (2 1)
|
||||
((install-lib-version (1 0))
|
||||
(options (with-surflets "Install with SUrflets (requires SSAX)" "<yes/no>" #t #t #t
|
||||
,parse-boolean ,show-boolean)))
|
||||
(let ((surflets? (get-option-value 'with-surflets)))
|
||||
(install-directory-contents "scheme" 'scheme)
|
||||
(install-directory "web-server" 'misc-shared)
|
||||
(install-directory-contents "doc" 'doc)
|
||||
|
||||
(let ((doc-dir (get-directory 'doc #t))
|
||||
(misc-shared-dir (get-directory 'misc-shared #t)))
|
||||
(create-symlink (string-append doc-dir "/html")
|
||||
(string-append misc-shared-dir
|
||||
"/web-server/root/htdocs/sunet-manual")))
|
||||
|
||||
|
||||
(let ((scheme-dir (get-directory 'scheme #t)))
|
||||
(write-to-load-script
|
||||
`((user)
|
||||
(config)
|
||||
(load ,(string-append scheme-dir "/packages.scm"))
|
||||
,@(if surflets?
|
||||
`((load ,(string-append scheme-dir "/httpd/surflets/packages.scm")))
|
||||
'())
|
||||
(user)))))
|
||||
)
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
***********************
|
||||
*** README for DNSD ***
|
||||
***********************
|
||||
|
||||
Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
<nofreude@informatik.uni-tuebingen.de>
|
||||
For copyright information, see the file COPYING which comes with
|
||||
the distribution.
|
||||
|
||||
|
||||
RUNNING THE NAMESERVER:
|
||||
-----------------------
|
||||
|
||||
1) Install SCSH, SUnet and SUnterlib
|
||||
---------------------------------
|
||||
|
||||
For instructions see www.scsh.net
|
||||
|
||||
|
||||
2) The configuration
|
||||
-----------------
|
||||
|
||||
There is a folder etc/ containing the files
|
||||
|
||||
dnsd-options.scm
|
||||
dnsd-zones.scm
|
||||
dnsd-pre.scm
|
||||
dnsd-post.scm
|
||||
|
||||
and some additional masterfile-examples.
|
||||
|
||||
You can copy this files to a directory of your liking
|
||||
or simply use the given path (from the SUnet-installation).
|
||||
|
||||
Either way, the path will be called <path-to-options>.
|
||||
|
||||
|
||||
You can customize the files:
|
||||
|
||||
2.1) dnsd-options.scm
|
||||
|
||||
Options for DNSD. Open the file for documentation.
|
||||
|
||||
|
||||
2.2) dnsd-zones.scm
|
||||
|
||||
Add/remove zones to DNSD. Documentation is included in the file.
|
||||
|
||||
|
||||
2.3) dnsd-pre.scm / dnsd-post.scm
|
||||
|
||||
You can customize the behaviour of query-processing within these
|
||||
two files.
|
||||
|
||||
|
||||
3) Run SCSH:
|
||||
---------
|
||||
|
||||
Load the CML-API from SUnterlib and SUnet.
|
||||
|
||||
> scsh -lel cml/load.scm -lel sunet/load.scm
|
||||
|
||||
|
||||
4) SCSH-REPL:
|
||||
----------
|
||||
|
||||
>,in dnsd
|
||||
|
||||
Start DNSD with
|
||||
|
||||
dnsd> (dnsd-start)
|
||||
|
||||
if the current working-directory is <path-to-options> or else use
|
||||
|
||||
dnsd> (dnsd-start <path-to-options>)
|
||||
|
||||
|
||||
5) While running DNSD:
|
||||
-------------------
|
||||
|
||||
* Reload the file dnsd-options.scm with the POSIX-signal USR1.
|
||||
* Reload the file dnsd-zones.scm with the POSIX-signal USR2.
|
||||
|
|
@ -1,170 +0,0 @@
|
|||
; ----------------------------
|
||||
; --- Query/Response-Cache ---
|
||||
; ----------------------------
|
||||
|
||||
; Cache for dnsd.scm
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; Revised version of the cache implementation seen in dns.scm.
|
||||
|
||||
; The cache stores data that was received during a recursive lookup.
|
||||
; The access-key of the cache consists of a question-name/class/type, the
|
||||
; data is a list of answers/additionals/authority.
|
||||
; It uses r/w-lock to avoid multiple simultaneous writes.
|
||||
|
||||
; Cache-Interface:
|
||||
; -----------------
|
||||
|
||||
; (dnsd-cache-clear!) - Removes the whole data.
|
||||
; (dnsd-cache-clean!) - Removes expired data.
|
||||
; (dnsd-cache-lookup? msg) - Searches for a cached reply.
|
||||
; (dnsd-cache-update! msg) - Updates the data to include the given msg.
|
||||
; (dnsd-cache-pretty-print) - Prints the cache.
|
||||
|
||||
;; Cache:
|
||||
;; ------
|
||||
|
||||
(define-record-type dnsd-cache :dnsd-cache
|
||||
(make-dnsd-cache data lock)
|
||||
dnsd-cache?
|
||||
(data get-dnsd-cache-data) ; cache-data-record-type
|
||||
(lock get-dnsd-cache-lock)) ; r/w-lock
|
||||
|
||||
(define-record-type cache-data :cache-data
|
||||
(make-cache-data answer expires)
|
||||
cache?
|
||||
(answer cache-data-answer) ; an answer as needed by lookup-query
|
||||
(expires cache-data-expires)) ; expiration time of the data (+ ttl (time))
|
||||
|
||||
|
||||
;; Create the cache:
|
||||
(define *dnsd-cache* (make-dnsd-cache (make-string-table) (make-r/w-lock)))
|
||||
|
||||
|
||||
;; Search for the shortest TTL in the message:
|
||||
;; TYPE: message -> number or #f
|
||||
(define (find-shortest-ttl msg)
|
||||
(let loop ((msg msg))
|
||||
(cond
|
||||
((dns-message? msg) (loop (dns-message-reply msg)))
|
||||
((message? msg) (fold-right
|
||||
(lambda (e m)
|
||||
(let ((ttl (resource-record-ttl e)))
|
||||
(if m
|
||||
(if (<= m ttl) m ttl)
|
||||
ttl)))
|
||||
#f
|
||||
(append (message-answers msg)
|
||||
(message-nameservers msg)
|
||||
(message-additionals msg)))))))
|
||||
|
||||
|
||||
;; Make a cache-key from the message:
|
||||
;; TYPE: message -> key-string
|
||||
(define (make-cache-key msg)
|
||||
(let ((question (car (message-questions msg))))
|
||||
(format #f "~a;~a;~a" (question-name question)
|
||||
(message-type-name (question-type question))
|
||||
(message-class-name (question-class question)))))
|
||||
|
||||
|
||||
;; Reset the cache:
|
||||
(define (dnsd-cache-clear!)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(set! *dnsd-cache*
|
||||
(make-dnsd-cache (make-string-table)
|
||||
(get-dnsd-cache-lock *dnsd-cache*))))))
|
||||
|
||||
|
||||
;; Remove expired data from the cache:
|
||||
(define (dnsd-cache-clean!)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(let ((time (time))
|
||||
(table (get-dnsd-cache-data *dnsd-cache*)))
|
||||
(table-walk (lambda (k e)
|
||||
(if (< time (cache-data-expires e))
|
||||
#t
|
||||
(table-set! table k #f)))
|
||||
table)))))
|
||||
|
||||
|
||||
; Look for data in the cache. If the found answer is expired return
|
||||
; #f and remove the answer from the cache.
|
||||
; TYPE: message -> '(l-of-answ l-of-auth l-of-addi boolean) or #f
|
||||
(define (dnsd-cache-lookup? msg)
|
||||
(let ((lock (get-dnsd-cache-lock *dnsd-cache*)))
|
||||
(obtain-R/w-lock lock)
|
||||
(let* ((data (get-dnsd-cache-data *dnsd-cache*))
|
||||
(key (make-cache-key msg))
|
||||
(cdata (table-ref data key)))
|
||||
(if cdata
|
||||
(if (< (time) (cache-data-expires cdata))
|
||||
(let ((res (cache-data-answer cdata)))
|
||||
(release-R/w-lock lock)
|
||||
res)
|
||||
(begin
|
||||
(release-R/w-lock lock)
|
||||
(obtain-r/W-lock lock)
|
||||
(table-set! data key #f)
|
||||
(release-r/W-lock lock)
|
||||
#f))
|
||||
(begin
|
||||
(release-R/w-lock lock)
|
||||
#f)))))
|
||||
|
||||
|
||||
;; Add the answer-sections (ansers/authority/additionals) and the authoritative
|
||||
;; flag of a message to the cache:
|
||||
;; TYPE: message -> unspecific
|
||||
(define (dnsd-cache-update! msg)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(let ((shortest-ttl (find-shortest-ttl msg)))
|
||||
(if (> shortest-ttl 0)
|
||||
(table-set!
|
||||
(get-dnsd-cache-data *dnsd-cache*)
|
||||
(make-cache-key msg)
|
||||
(make-cache-data
|
||||
(list (message-answers msg)
|
||||
(message-nameservers msg)
|
||||
(message-additionals msg)
|
||||
(header-flags (message-header msg))) ; authoritative?
|
||||
(+ (time) shortest-ttl)))
|
||||
#f)))))
|
||||
|
||||
|
||||
;; Display the cache:
|
||||
(define (dnsd-cache-pretty-print)
|
||||
(with-R/w-lock
|
||||
(get-dnsd-cache-lock *dnsd-cache*)
|
||||
(lambda ()
|
||||
(let ((data (get-dnsd-cache-data *dnsd-cache*)))
|
||||
(display "DNSD-CACHE:\n")
|
||||
(display "-----------\n")
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(let ((cache-data (cache-data-answer e)))
|
||||
(display "\n*Question: ")
|
||||
(display k)(newline)
|
||||
(display " ---------\n")
|
||||
(display " Expires in: ")
|
||||
(display (- (cache-data-expires e) (time)))
|
||||
(display " seconds.\n")
|
||||
(display " \n Answer-Section:\n\n")
|
||||
(map (lambda (x) (pretty-print-dns-message x)) (car cache-data))
|
||||
(display " \n Authority-Section:\n\n")
|
||||
(map (lambda (y) (pretty-print-dns-message y)) (cadr cache-data))
|
||||
(display " \n Additionals-Section:\n\n")
|
||||
(map (lambda (z) (pretty-print-dns-message z)) (caddr cache-data))))
|
||||
data)))))
|
||||
|
|
@ -1,674 +0,0 @@
|
|||
;; ---------------------
|
||||
;; --- dnsd-database ---
|
||||
;; ---------------------
|
||||
|
||||
; A simple database for dnsd.scm
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; Naming-Scheme:
|
||||
; --------------
|
||||
|
||||
; dbi- == No locks (should not be exported)
|
||||
; db- == With locks
|
||||
|
||||
; Lock-Safe Database-Interface:
|
||||
; -----------------------------
|
||||
|
||||
; (db-clear-database)
|
||||
; (db-clear-zone name class)
|
||||
; (db-update-zone zone-list)
|
||||
; (db-get-zone name class)
|
||||
; (db-get-zone-for-axfr name class)
|
||||
; (db-get-zone-soa-rr name class)
|
||||
; (db-pretty-print)
|
||||
|
||||
; Query/Database-Interface
|
||||
; ------------------------
|
||||
|
||||
; (db-lookup-rec qname class type)
|
||||
|
||||
; Database Structure:
|
||||
; -------------------
|
||||
; db-class-table: hash-table to db-zones
|
||||
; |
|
||||
; |-->db-zones-table: hash-table to db-zone
|
||||
; |
|
||||
; |-->db-zone: hash-table to db-rr
|
||||
; |
|
||||
; |-->db-rr-table: hash-table to lists of resource-records
|
||||
; of a given message-type
|
||||
|
||||
|
||||
;; Some stuff:
|
||||
;; -----------
|
||||
|
||||
;; Should be a dnsd-option?
|
||||
(define *debug-info* #t)
|
||||
|
||||
|
||||
;; Make a key for the database:
|
||||
;; TYPE: string -> string
|
||||
(define (make-key-name name)
|
||||
(let ((last-char (string-ref name (- (string-length name) 1))))
|
||||
(string-downcase (if (not (char=? #\. last-char))
|
||||
(string-append name ".")
|
||||
name))))
|
||||
|
||||
;; Compare the first string with the rear of the second string.
|
||||
;; TYPE: string x string -> boolean
|
||||
(define (string-ci-zone-name=? zone name)
|
||||
(let ((l1 (string-length zone))
|
||||
(l2 (string-length name)))
|
||||
(if (<= l1 l2) (string-ci=? zone (substring name (- l2 l1) l2)) #f)))
|
||||
|
||||
;; Search a list of resource-records for the soa-rr:
|
||||
;; TYPE: list-of-rrs -> soa-rr or #f
|
||||
(define (maybe-get-soa-rr l)
|
||||
(let loop ((l l))
|
||||
(if (null? l)
|
||||
#f
|
||||
(let ((e (car l)))
|
||||
(if (resource-record-data-soa?
|
||||
(resource-record-data e))
|
||||
e
|
||||
(loop (cdr l)))))))
|
||||
|
||||
|
||||
;; Get the name of a zone from a soa-rr within a zone-list:
|
||||
;; TYPE: list-of-rrs -> zone-name or #f
|
||||
(define (maybe-get-soa-rr-name l)
|
||||
(and-let* ((soa-rr (maybe-get-soa-rr l)))
|
||||
(resource-record-name soa-rr)))
|
||||
|
||||
|
||||
;; TYPE : list-or-rrs -> list-of-rrs
|
||||
(define (get-zone-list-w/o-soa l)
|
||||
(fold-right
|
||||
(lambda (e l)
|
||||
(if (resource-record-data-soa? (resource-record-data e)) l (cons e l)))
|
||||
'() l))
|
||||
|
||||
;; TODO: Do this different...
|
||||
(define display-debug
|
||||
(lambda args
|
||||
(if *debug-info*
|
||||
(begin
|
||||
(display "dnsd: ")
|
||||
(map (lambda (e) (display e) (display " ")) args)
|
||||
(newline))
|
||||
#f)))
|
||||
|
||||
;; Duplicate a resource-record: (Needed for wildcard-replies)
|
||||
(define (duplicate-rr name rr)
|
||||
(make-resource-record name
|
||||
(resource-record-type rr)
|
||||
(resource-record-class rr)
|
||||
(resource-record-ttl rr)
|
||||
(resource-record-data rr)))
|
||||
|
||||
|
||||
; ---------------------------
|
||||
; --- Database definition ---
|
||||
; ---------------------------
|
||||
|
||||
; Record-types:
|
||||
; -------------
|
||||
|
||||
; db-rr-table stores the resource-records of ONE domain-name.
|
||||
; hash-table is a symbol-table with 'message-type' as keys
|
||||
; and a list of resource-record of the key-message-type as data.
|
||||
; glue-data stores the information (as boolean) if the given domain-name
|
||||
; is for glue-data or official.
|
||||
(define-record-type db-rr-table :db-rr-table
|
||||
(really-make-db-rr-table hash-table glue-data)
|
||||
db-rr-table?
|
||||
(hash-table db-rr-table-hash-table)
|
||||
(glue-data db-rr-table-glue-data? set-db-rr-table-glue-data?!))
|
||||
|
||||
(define (make-db-rr-table) (really-make-db-rr-table (make-symbol-table) #f))
|
||||
|
||||
|
||||
; db-zone stores data (in form of db-rr-tables) for an entire zone
|
||||
; as given by e.g. a masterfile
|
||||
; hash-table a string-table. Keys are the domain-names of the zone
|
||||
; to link to db-rr-tables.
|
||||
; name the name of the zone.
|
||||
; soa-rr for easy-access :-)
|
||||
(define-record-type db-zone :db-zone
|
||||
(really-make-db-zone hash-table name soa-rr)
|
||||
db-zone?
|
||||
(hash-table db-zone-table)
|
||||
(name db-zone-name)
|
||||
(soa-rr get-db-zone-soa-rr))
|
||||
|
||||
(define (make-db-zone name soa-rr)
|
||||
(let ((primary-name (resource-record-data-soa-mname
|
||||
(resource-record-data soa-rr))))
|
||||
(really-make-db-zone (make-string-table) name soa-rr)))
|
||||
|
||||
|
||||
; db-zones-table stores all zones of a given message-class
|
||||
; hash-table key is the zone-name.
|
||||
(define-record-type db-zones-table :db-zones-table
|
||||
(really-make-db-zones-table hash-table)
|
||||
db-zones-table?
|
||||
(hash-table db-zones-table-hash-table))
|
||||
|
||||
(define (make-db-zones-table) (really-make-db-zones-table (make-string-table)))
|
||||
|
||||
|
||||
; db-class-table entry-point for the db.
|
||||
; hash-table key is the message-class (e.g. in) data are db-zones-tables
|
||||
; r/w-lock lock for exclusive-write-access.
|
||||
(define-record-type db-class-table :db-class-table
|
||||
(really-make-db-class-table hash-table r/w-lock)
|
||||
db-class-table?
|
||||
(hash-table db-class-table-hash-table set-db-class-table-hash-table!)
|
||||
(r/w-lock db-class-table-r/w-lock))
|
||||
|
||||
(define *database* (really-make-db-class-table (make-symbol-table)
|
||||
(make-r/w-lock)))
|
||||
|
||||
|
||||
; Predicates:
|
||||
; -----------
|
||||
|
||||
; Check if there is data for a given message-class:
|
||||
; TYPE: message-class -> boolean
|
||||
(define (dbi-class? class)
|
||||
(if (table-ref (db-class-table-hash-table *database*)
|
||||
(message-class-name class))
|
||||
#t #f))
|
||||
|
||||
|
||||
;; Modifiers:
|
||||
;; ----------
|
||||
|
||||
;; Delete the whole data in the database:
|
||||
(define (db-clear-database)
|
||||
(with-r/W-lock
|
||||
(db-class-table-r/w-lock *database*)
|
||||
(lambda ()
|
||||
(set-db-class-table-hash-table! *database* (make-symbol-table)))))
|
||||
|
||||
|
||||
;; Delete a zone (if present) with name 'name' from the database:
|
||||
;; TYPE: string x message-class -> boolean
|
||||
(define (db-clear-zone name class)
|
||||
(with-r/W-lock
|
||||
(db-class-table-r/w-lock *database*)
|
||||
(lambda ()
|
||||
(and-let* ((whatever (dbi-class? class))
|
||||
(class-table (db-class-table-hash-table *database*))
|
||||
(zones-type (table-ref class-table (message-class-name class)))
|
||||
(zones-table (db-zones-table-hash-table zones-type))
|
||||
(key-name (make-key-name name))
|
||||
(whatever (table-ref zones-table key-name)))
|
||||
(table-set! zones-table key-name #f)))))
|
||||
|
||||
|
||||
;; Stuff for db-add-zone:
|
||||
|
||||
;; Add a new class (if not already present) to the database:
|
||||
;; TYPE: message-class -> unspecific
|
||||
(define (dbi-maybe-add-class class)
|
||||
(if (not (dbi-class? class))
|
||||
(table-set! (db-class-table-hash-table *database*)
|
||||
(message-class-name class)
|
||||
(make-db-zones-table))))
|
||||
|
||||
|
||||
|
||||
;; --- Detection of Zone-Rules ---
|
||||
|
||||
|
||||
;; Detect and mark glue data (domains with NS and all of their subdomains)
|
||||
;; Give a warning, if the zone-tree is broken
|
||||
;; TYPE: db-def-table x string -> unspecific
|
||||
(define (dbi-mark-glue-in-zone def-table zone-name)
|
||||
(let ((tree (db-zone-table def-table)))
|
||||
(table-walk
|
||||
(lambda (key element)
|
||||
(if (table-ref (db-rr-table-hash-table element)
|
||||
(message-type-name (message-type a)))
|
||||
(let loop ((name key))
|
||||
(if (string-ci=? name zone-name)
|
||||
#t
|
||||
(let ((zone-entry (table-ref tree name)))
|
||||
(if zone-entry
|
||||
(if (table-ref (db-rr-table-hash-table zone-entry)
|
||||
(message-type-name (message-type ns)))
|
||||
(set-db-rr-table-glue-data?! element #t)
|
||||
(loop (cut-name name)))
|
||||
;; Be tolerant if the domain tree is broken...
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Warning (re)loading zone ~S. Broken tree: Domain ~S is missing!"
|
||||
zone-name name)
|
||||
(loop (cut-name name)))))))
|
||||
#t))
|
||||
tree)))
|
||||
|
||||
|
||||
;; Ensures the min. TTL from the soa-rr of the zone. Has to be called
|
||||
;; after dbi-mark-glue-in-zone!
|
||||
;; TYPE: db-def-table x soa-rr -> unspecific
|
||||
(define (dbi-ensure-min-ttl def-table soa-rr)
|
||||
(let ((min-ttl (resource-record-data-soa-minimum
|
||||
(resource-record-data soa-rr))))
|
||||
(table-walk
|
||||
(lambda (key element)
|
||||
(if (not (db-rr-table-glue-data? element))
|
||||
(table-walk
|
||||
(lambda (tkey telement)
|
||||
(table-set! (db-rr-table-hash-table element)
|
||||
tkey
|
||||
(map (lambda (e)
|
||||
(let ((rr-ttl (resource-record-ttl e)))
|
||||
(make-resource-record
|
||||
(resource-record-name e)
|
||||
(resource-record-type e)
|
||||
(resource-record-class e)
|
||||
(if (< rr-ttl min-ttl)
|
||||
min-ttl rr-ttl)
|
||||
(resource-record-data e))))
|
||||
telement)))
|
||||
(db-rr-table-hash-table element))))
|
||||
(db-zone-table def-table))))
|
||||
|
||||
|
||||
;; Give a warning, if a Zone with a CNAME-RR contains other stuff...
|
||||
;; TYPE: db-def-table -> unspecific
|
||||
(define (dbi-cname-warning def-table zone-name)
|
||||
(table-walk
|
||||
(lambda (key element)
|
||||
(let ((rr-table (db-rr-table-hash-table element))
|
||||
(cname (message-type-name (message-type cname))))
|
||||
(if (table-ref rr-table cname)
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(if (not (eq? k cname))
|
||||
(dnsd-log (syslog-level info)
|
||||
"Warning (re)loading zone ~S. Domain ~S contains a CNAME-RR and other RRs at the same time."
|
||||
zone-name key)
|
||||
(if (not (= 1 (length e)))
|
||||
(dnsd-log (syslog-level info)
|
||||
"Warning (re)loading zone ~S. Domain ~S contains 2 or more CNAME-RRs!"
|
||||
zone-name key))))
|
||||
rr-table))))
|
||||
(db-zone-table def-table)))
|
||||
|
||||
|
||||
;; This functions have to be called in the given order:
|
||||
;; TYPE: db-def-table x string x soa-rr -> unspecific
|
||||
(define (dbi-set-zone-requirements def-table zone-name soa-rr)
|
||||
(dbi-mark-glue-in-zone def-table zone-name)
|
||||
(dbi-ensure-min-ttl def-table soa-rr)
|
||||
(dbi-cname-warning def-table zone-name))
|
||||
|
||||
|
||||
;; Adds a list of resource-records to a zone-definition-table:
|
||||
(define (dbi-add-zone-list def-table rr-list)
|
||||
(let ((tree (db-zone-table def-table)))
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(let* ((domain-key (make-key-name (resource-record-name e)))
|
||||
(type-key (message-type-name (resource-record-type e)))
|
||||
(rr-type (table-ref tree domain-key)))
|
||||
;; Create & link a new rr-table for the first entry of the rr-type:
|
||||
(if (not (db-rr-table? rr-type))
|
||||
(begin (set! rr-type (make-db-rr-table))
|
||||
(table-set! tree domain-key rr-type)))
|
||||
(let* ((rr-table (db-rr-table-hash-table rr-type))
|
||||
(entry (table-ref rr-table type-key)))
|
||||
(if entry
|
||||
(table-set! rr-table type-key (cons e entry))
|
||||
(table-set! rr-table type-key (cons e '()))))))
|
||||
rr-list)))
|
||||
|
||||
|
||||
;; Adds a zone to the database which is given as a list of resource-records.
|
||||
;; Notes: * db-add-zone doesn't overwrite existing zones.
|
||||
;; * Just for internal use.
|
||||
;; TYPE: list-of-rrs -> boolean
|
||||
(define (db-add-zone zone-list)
|
||||
(with-r/W-lock
|
||||
(db-class-table-r/w-lock *database*)
|
||||
(lambda ()
|
||||
(and-let* ((soa-rr (maybe-get-soa-rr zone-list))
|
||||
(zone-name (resource-record-name soa-rr))
|
||||
(zone-key (make-key-name zone-name))
|
||||
(zone-class (resource-record-class soa-rr)))
|
||||
;; Add another class to the database?
|
||||
(dbi-maybe-add-class zone-class)
|
||||
;; Get the zone-stuff to insert the zone into together:
|
||||
(let* ((zone-table (db-zones-table-hash-table
|
||||
(table-ref (db-class-table-hash-table *database*)
|
||||
(message-class-name zone-class)))))
|
||||
;; Don't overwrite an existing zone
|
||||
(if (table-ref zone-table zone-key) #f
|
||||
;; Add the zone to the db & ensure data integrity:
|
||||
(let* ((zone-dtable (make-db-zone zone-key soa-rr)))
|
||||
(table-set! zone-table zone-key zone-dtable)
|
||||
(dbi-add-zone-list zone-dtable zone-list)
|
||||
(dbi-set-zone-requirements zone-dtable zone-name soa-rr))))))))
|
||||
|
||||
|
||||
;; Update a zone if the serial of the new soa isn't the same or less.
|
||||
;; TYPE: list-of-rrs -> boolean
|
||||
(define (db-update-zone zone-list)
|
||||
(and-let* ((new-soa-rr (maybe-get-soa-rr zone-list))
|
||||
(new-serial (resource-record-data-soa-serial
|
||||
(resource-record-data new-soa-rr)))
|
||||
(zone-name (make-key-name (resource-record-name new-soa-rr)))
|
||||
(zone-class (resource-record-class new-soa-rr)))
|
||||
(let ((old-soa-rr (db-get-zone-soa-rr zone-name zone-class)))
|
||||
(cond
|
||||
((or (not old-soa-rr)
|
||||
(and old-soa-rr
|
||||
(> new-serial (resource-record-data-soa-serial
|
||||
(resource-record-data old-soa-rr)))))
|
||||
(db-clear-zone zone-name zone-class)
|
||||
(db-add-zone zone-list))
|
||||
((= new-serial (resource-record-data-soa-serial
|
||||
(resource-record-data old-soa-rr)))
|
||||
#t) ;; !!! If the serial hasn't changed it's considered successfull.
|
||||
(else #f)))))
|
||||
|
||||
|
||||
; Get all resource records for a zone.
|
||||
; TYPE: string x message-class -> list-of-rrs or #f
|
||||
(define (db-get-zone name class)
|
||||
(with-R/w-lock
|
||||
(db-class-table-r/w-lock *database*)
|
||||
(lambda ()
|
||||
(and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
|
||||
(message-class-name class)))
|
||||
(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
|
||||
(make-key-name name)))
|
||||
(zone-tree-tree (db-zone-table the-zone-type))
|
||||
(res-list '()))
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(if e
|
||||
(table-walk (lambda (k1 e1)
|
||||
(set! res-list (append e1 res-list)))
|
||||
(db-rr-table-hash-table e))))
|
||||
zone-tree-tree)
|
||||
res-list))))
|
||||
|
||||
|
||||
; ; Get the timestamp for a zone.
|
||||
; ; TYPE: string x message-class -> number or #f
|
||||
; (define (db-get-zone-timestamp name class)
|
||||
; (with-R/w-lock
|
||||
; (db-class-table-r/w-lock *database*)
|
||||
; (lambda ()
|
||||
; (and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
|
||||
; (message-class-name class)))
|
||||
; (the-zone-type (table-ref (db-zones-table-hash-table zone-type)
|
||||
; (make-key-name name))))
|
||||
; (get-db-zone-timestamp the-zone-type)))))
|
||||
|
||||
|
||||
;; Get the soa-rr of a zone.
|
||||
;; TYPE: string x message-class -> soa-rr or #f
|
||||
(define (db-get-zone-soa-rr name class)
|
||||
(with-R/w-lock
|
||||
(db-class-table-r/w-lock *database*)
|
||||
(lambda ()
|
||||
(and-let* ((zone-type (table-ref (db-class-table-hash-table *database*)
|
||||
(message-class-name class)))
|
||||
(the-zone-type (table-ref (db-zones-table-hash-table zone-type)
|
||||
(make-key-name name))))
|
||||
(get-db-zone-soa-rr the-zone-type)))))
|
||||
|
||||
|
||||
; Get all rrs of a zone in an AXFR-ready list: '(soa-rr rr rr ... rr soa-rr)
|
||||
; TYPE: string x message-class -> list-of-rrs or #f
|
||||
(define (db-get-zone-for-axfr name class)
|
||||
(and-let* ((zone-list (db-get-zone name class))
|
||||
(soa-l (list (maybe-get-soa-rr zone-list)))
|
||||
(rest-l (get-zone-list-w/o-soa zone-list)))
|
||||
(append soa-l rest-l soa-l)))
|
||||
|
||||
|
||||
;; Look for the zone in which 'name' is a subdomain or the domain of the
|
||||
;; given zones. Returns the zone which is the nearest ancestor to 'name'.
|
||||
;; TYPE: name x message-class -> db-zone-record-type or #f
|
||||
(define (dbi-lookup-zone-for-name name class)
|
||||
(and-let* ((zone-record (table-ref (db-class-table-hash-table *database*)
|
||||
(message-class-name class)))
|
||||
(zone-table (db-zones-table-hash-table zone-record))
|
||||
(ancestors '())
|
||||
(zone-key ""))
|
||||
;; Look for zones who are ancestors to key:
|
||||
(table-walk (lambda (k e)
|
||||
(if (string-ci-zone-name=? k (make-key-name name))
|
||||
(set! ancestors (cons k ancestors))))
|
||||
zone-table)
|
||||
(cond
|
||||
((null? ancestors) #f)
|
||||
((= 1 (length ancestors)) (set! zone-key (car ancestors)))
|
||||
;; If more ancestors are found get the closest one:
|
||||
(else (set! zone-key (fold-right (lambda (a b) (if (< (string-length a)
|
||||
(string-length b))
|
||||
b a))
|
||||
"" ancestors))))
|
||||
(table-ref zone-table zone-key)))
|
||||
|
||||
|
||||
; Look for the entries of type 'type' in a given db-rr-table
|
||||
; TYPE: db-rr-table-rec-type x message-type -> list-of-rrs
|
||||
(define (dbi-lookup-rrs rr-record-type type)
|
||||
(let ((rr-table (db-rr-table-hash-table rr-record-type)))
|
||||
(cond
|
||||
((eq? (message-type *) type) ; ... return all records.
|
||||
(let ((res '())) (table-walk (lambda (k e) (set! res (cons e res)))
|
||||
rr-table)
|
||||
res))
|
||||
(else (let ((res (table-ref rr-table (message-type-name type))))
|
||||
(if res res '()))))))
|
||||
|
||||
|
||||
;; Look for the entries of type 'type' in a given db-rr-table
|
||||
;; TYPE: db-rr-table-rec-type x messag-type -> list-of-rrs or #f
|
||||
(define (dbi-lookup-rrs? rr-record-type type)
|
||||
(let ((res (dbi-lookup-rrs rr-record-type type)))
|
||||
(if (null? res) #f res)))
|
||||
|
||||
|
||||
;; --------------------------------
|
||||
;; --- Query/Database Interface ---
|
||||
;; --------------------------------
|
||||
|
||||
;; Requests for mailbox-related resource-records will be handled as mx requests:
|
||||
;; TYPE: string x type x class ->
|
||||
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
|
||||
(define (db-lookup-rec qname class type)
|
||||
(obtain-R/w-lock (db-class-table-r/w-lock *database*))
|
||||
(receive
|
||||
(anli auli adli aufl)
|
||||
(dbi-lookup-rec-int qname class (if (eq? type (message-type mailb))
|
||||
(message-type mx)
|
||||
type) ; Mailb == mx query
|
||||
'())
|
||||
(release-R/w-lock (db-class-table-r/w-lock *database*))
|
||||
(values anli auli adli aufl)))
|
||||
|
||||
|
||||
;; Main part of the algorithm as described in RFC 1034. Returns found rrs and
|
||||
;; a flag, indicating if the answer is authoritative.
|
||||
;; The flag ist needed, because of glue-data, that could be part of the
|
||||
;; response. The operand 'c-list' is used to detect and avoid cname-loops.
|
||||
;; TYPE: string x type x class x c-list ->
|
||||
;; '(list-of-answers-rrs list-of-nameservers-rrs list-of-additional-rrs boolean)
|
||||
(define (dbi-lookup-rec-int qname class type c-list)
|
||||
(let ((zone (dbi-lookup-zone-for-name qname class)))
|
||||
(if (not zone)
|
||||
(values '() '() '() #f) ; no zone in db
|
||||
(let ((zone-name (db-zone-name zone)))
|
||||
;; loop over the labels of the name. eg. my.example. / example. / .
|
||||
;; keep track of the iterations (mostly for wildcard-match support)
|
||||
(let loop ((name qname) (loop-count 0))
|
||||
(let ((rr-table (table-ref (db-zone-table zone)
|
||||
(make-key-name name))))
|
||||
(if rr-table
|
||||
(cond
|
||||
;; A wildcard match
|
||||
((= 1 loop-count)
|
||||
;; Set the name of the rrs from * to qname.
|
||||
(values (map (lambda (e) (duplicate-rr qname e))
|
||||
(dbi-lookup-rrs rr-table type)) '() '() #t))
|
||||
;; Direct match (0) or glue-data match (>1)
|
||||
((or (= 0 loop-count) (< 1 loop-count))
|
||||
(cond ;c2
|
||||
;; Found glue data.
|
||||
((and (dbi-lookup-rrs? rr-table (message-type ns))
|
||||
(not (string-ci=? name zone-name))
|
||||
(not (eq? (message-type ns) type)))
|
||||
(let* ((ns-rr-list (dbi-lookup-rrs?
|
||||
rr-table (message-type ns)))
|
||||
(res-l
|
||||
(fold-right
|
||||
(lambda (e l)
|
||||
(receive
|
||||
(anli auli adli aufl)
|
||||
(dbi-lookup-rec-int
|
||||
(resource-record-data-ns-name
|
||||
(resource-record-data e))
|
||||
class (message-type a) c-list)
|
||||
(list (car l) (cadr l)
|
||||
(append anli (caddr l)) #f)))
|
||||
'(() () () #t) ns-rr-list)))
|
||||
(values (car res-l) (append ns-rr-list (cadr res-l))
|
||||
(caddr res-l) #f)))
|
||||
;; Looking for correct information (direct match)
|
||||
((= 0 loop-count)
|
||||
(cond ;c3
|
||||
;; CNAME: Causes an additional lookup
|
||||
((dbi-lookup-rrs? rr-table (message-type cname))
|
||||
=> (lambda (cname-rr-list)
|
||||
(let ((cname-rr (car cname-rr-list)))
|
||||
(if (eq? (message-type cname) type)
|
||||
(values (list cname-rr) '() '() #t)
|
||||
(begin
|
||||
(if (fold-right
|
||||
(lambda (e b)
|
||||
(or (string-ci=? e name) b))
|
||||
#f c-list)
|
||||
(begin
|
||||
;; Problem?: The loop will be send
|
||||
;; as a response... .
|
||||
(display-debug " Found cname-loop")
|
||||
(values '() '() '() #t))
|
||||
(receive
|
||||
(anli auli adli aufl)
|
||||
(dbi-lookup-rec-int
|
||||
(resource-record-data-cname-name
|
||||
(resource-record-data cname-rr))
|
||||
class type (cons name c-list))
|
||||
(values (append (list cname-rr) anli)
|
||||
auli adli
|
||||
(and aufl #t)))))))))
|
||||
;; MX: Causes an additional lookup
|
||||
((eq? (message-type mx) type)
|
||||
(let* ((mx-rrs (dbi-lookup-rrs rr-table type))
|
||||
(res-l
|
||||
(fold-right
|
||||
(lambda (e l)
|
||||
(receive
|
||||
(anli auli adli aufl)
|
||||
(dbi-lookup-rec-int
|
||||
(resource-record-data-mx-exchanger
|
||||
(resource-record-data e))
|
||||
class (message-type a) c-list)
|
||||
(list (car l) (cadr l)
|
||||
(append anli (caddr l))
|
||||
(and #t (cadddr l)))))
|
||||
'(() () () #t) mx-rrs)))
|
||||
(values (append mx-rrs (car res-l)) (cadr res-l)
|
||||
(caddr res-l) (and #t (cadddr res-l)))))
|
||||
;; Glue-Data entries aren't authoritative:
|
||||
((db-rr-table-glue-data? rr-table)
|
||||
(values (dbi-lookup-rrs rr-table type) '() '() #f))
|
||||
;; Found a match with no additional lookups.
|
||||
(else
|
||||
(values (dbi-lookup-rrs rr-table type) '() '() #t))))
|
||||
;; Got a dns-name-error (RCODE=3)
|
||||
(else (values '() '() '() #t)))))
|
||||
;; Found no match for the current name.
|
||||
(cond
|
||||
((> (string-length zone-name) (string-length name))
|
||||
(error "Woh, found a bug... ")) ; Just for safety...
|
||||
;; Search for wildcards in the first iteration:
|
||||
((= 0 loop-count)
|
||||
(loop (string-append "*." (cut-name name)) 1))
|
||||
(else (loop (cut-name name) (+ 1 loop-count)))))))))))
|
||||
|
||||
|
||||
;; ------------------------------
|
||||
;; --- Database pretty-print: ---
|
||||
;; ------------------------------
|
||||
|
||||
(define (pretty-print-record-type rt)
|
||||
(cond
|
||||
((db-class-table? rt)
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(newline)
|
||||
(display "DB-Class: ")
|
||||
(display k)(newline)
|
||||
(pretty-print-record-type e))
|
||||
(db-class-table-hash-table rt)))
|
||||
((db-zones-table? rt)
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(display " DB-Zone: ")
|
||||
(display k)
|
||||
(newline)
|
||||
(pretty-print-record-type e))
|
||||
(db-zones-table-hash-table rt)))
|
||||
((db-zone? rt)
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(display " DB-Zone-Entries: ")
|
||||
(display k)
|
||||
(newline)
|
||||
(pretty-print-record-type e))
|
||||
(db-zone-table rt)))
|
||||
((db-rr-table? rt)
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(display " DB-RR-Table: ")
|
||||
(display k)
|
||||
(newline)
|
||||
(display " Glue-data: ")
|
||||
(display (db-rr-table-glue-data? rt))
|
||||
(newline)
|
||||
(newline)
|
||||
(pretty-print-record-type e))
|
||||
(db-rr-table-hash-table rt)))
|
||||
((list? rt)
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(pretty-print-dns-message e)
|
||||
(newline))
|
||||
rt))
|
||||
(else (newline))))
|
||||
|
||||
(define (db-pretty-print)
|
||||
(with-R/w-lock
|
||||
(db-class-table-r/w-lock *database*)
|
||||
(lambda ()
|
||||
(newline)
|
||||
(display "DNS-Server-Database:")(newline)
|
||||
(display "--------------------")(newline)
|
||||
(pretty-print-record-type *database*))))
|
||||
|
|
@ -1,134 +0,0 @@
|
|||
;; ------------------------
|
||||
;; --- Database-Options ---
|
||||
;; ------------------------
|
||||
|
||||
; Database-Options for DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; The format and style of the option procedures is the same as seen
|
||||
; in the SUNet HTTPD & FTPD - Files
|
||||
|
||||
|
||||
(define-record-type dnsddb-options :dnsddb-options
|
||||
(really-make-dnsddb-options name class type primary? file filetype master-name master-ip)
|
||||
dnsddb-options?
|
||||
(name dnsddb-options-name set-dnsddb-options-name!)
|
||||
(class dnsddb-options-class set-dnsddb-options-class!)
|
||||
(type dnsddb-options-type set-dnsddb-options-type!)
|
||||
(primary? dnsddb-options-primary? set-dnsddb-options-primary?!) ;;depreaced
|
||||
(file dnsddb-options-file set-dnsddb-options-file!)
|
||||
(filetype dnsddb-options-filetype set-dnsddb-options-filetype!)
|
||||
(master-name dnsddb-options-master-name set-dnsddb-options-master-name!)
|
||||
(master-ip dnsddb-options-master-ip set-dnsddb-options-master-ip!))
|
||||
|
||||
|
||||
(define (make-default-dnsddb-options)
|
||||
(really-make-dnsddb-options
|
||||
"" ;; the name of the zone
|
||||
(message-class in)
|
||||
"primary" ;;
|
||||
#t ;; is primary?
|
||||
"" ;; a filename
|
||||
"dnsd" ;; "dnsd" or "rfc"
|
||||
#f ;; Has to be set by dnsd-zones.scm, e.g. "dns01.my.example."
|
||||
#f)) ;; e.g. "192.168.2.1" or #f
|
||||
|
||||
|
||||
(define (copy-dnsddb-options options)
|
||||
(really-make-dnsddb-options
|
||||
(dnsddb-options-name options)
|
||||
(dnsddb-options-class options)
|
||||
(dnsddb-options-type options)
|
||||
(dnsddb-options-primary? options)
|
||||
(dnsddb-options-file options)
|
||||
(dnsddb-options-filetype options)
|
||||
(dnsddb-options-master-name options)
|
||||
(dnsddb-options-master-ip options)))
|
||||
|
||||
|
||||
(define (make-dnsddb-options-transformer set-option!)
|
||||
(lambda (new-value . stuff)
|
||||
(let ((new-options (if (not (null? stuff))
|
||||
(copy-dnsddb-options (car stuff))
|
||||
(make-default-dnsddb-options))))
|
||||
(set-option! new-options new-value)
|
||||
new-options)))
|
||||
|
||||
|
||||
(define with-name
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-name!))
|
||||
(define with-class
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-class!))
|
||||
(define with-type
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-type!))
|
||||
(define with-primary?
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-primary?!))
|
||||
(define with-file
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-file!))
|
||||
(define with-filetype
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-filetype!))
|
||||
(define with-master-name
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-master-name!))
|
||||
(define with-master-ip
|
||||
(make-dnsddb-options-transformer set-dnsddb-options-master-ip!))
|
||||
|
||||
|
||||
(define (make-dnsddb-options . stuff)
|
||||
(let loop ((options (make-default-dnsddb-options))
|
||||
(stuff stuff))
|
||||
(if (null? stuff)
|
||||
options
|
||||
(let* ((transformer (car stuff))
|
||||
(value (cadr stuff)))
|
||||
(loop (transformer value options)
|
||||
(cddr stuff))))))
|
||||
|
||||
|
||||
(define (make-db-options-from-list o-list)
|
||||
(let ((options (make-default-dnsddb-options)))
|
||||
(if (eq? (car o-list) 'zone)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(let ((id (car e))
|
||||
(value (cadr e)))
|
||||
(case id
|
||||
((name)
|
||||
(if (string? value)
|
||||
(set-dnsddb-options-name!
|
||||
options (make-fqdn-name value))
|
||||
(error "Bad option argument.")))
|
||||
((type)
|
||||
(if (or (string-ci=? "primary" value)
|
||||
(string-ci=? "secondary" value)
|
||||
(string-ci=? "master" value)
|
||||
(string-ci=? "slave" value))
|
||||
(set-dnsddb-options-type! options value)
|
||||
(error "Bad option argument.")))
|
||||
((file)
|
||||
(if (and (string? value) (file-name-non-directory? value))
|
||||
(set-dnsddb-options-file! options value)
|
||||
(error "Bad option argument.")))
|
||||
((filetype)
|
||||
(if (or (string-ci=? "dnsd" value)
|
||||
(string-ci=? "rfc" value))
|
||||
(set-dnsddb-options-filetype! options value)
|
||||
(error "Bad option argument.")))
|
||||
((master-name)
|
||||
(if (string? value)
|
||||
(set-dnsddb-options-master-name! options value)
|
||||
(error "Bad option argument.")))
|
||||
((master-ip)
|
||||
(if (string? value)
|
||||
(set-dnsddb-options-master-ip! options value)
|
||||
(error "Bad option argument.")))
|
||||
(else (error "Bad option.")))))
|
||||
(cdr o-list))
|
||||
options)
|
||||
(error "Not an option list."))))
|
||||
|
|
@ -1,836 +0,0 @@
|
|||
; ------------------
|
||||
; --- DNS-Server ---
|
||||
; ------------------
|
||||
|
||||
; A DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; This file is (maybe) part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; TODO:
|
||||
; -----
|
||||
|
||||
; Testing, testing, testing...
|
||||
|
||||
; Nice stuff to have:
|
||||
; * IXFR
|
||||
; * IPv6-Support
|
||||
; * Support more types (& other classes)
|
||||
; * Masterfile-parser: $GENERATE ...
|
||||
; * Some accurate way to limit the cache to a certain mem-size?
|
||||
; * Better syslog interaction.
|
||||
|
||||
; Doc-TODO:
|
||||
; - Master-File-Parser
|
||||
; - Cache
|
||||
; - Database
|
||||
; - dnsd messages
|
||||
; - dnsd-options
|
||||
|
||||
; Message Example (Query):
|
||||
; ------------------------
|
||||
|
||||
; (define *query-example*
|
||||
; (make-message (make-header 0815 (make-flags 1 0 #f #f #f #f 0 0) 1 0 0 0)
|
||||
; (list (make-question "uni-tuebingen.de."
|
||||
; (message-type a)
|
||||
; (message-class in)))
|
||||
; '() '() '() '()))
|
||||
|
||||
|
||||
;; Assignment procedures for messages (basically dns.scm extension)
|
||||
;; ----------------------------------------------------------------
|
||||
|
||||
;; Set the truncation bit of an octet-message (for UDP):
|
||||
;; TYPE: message x boolean -> message
|
||||
(define (octet-msg-change-truncation msg bool)
|
||||
(let* ((id (take msg 2))
|
||||
(rest (drop msg 3))
|
||||
(flag (char->ascii (caddr msg)))
|
||||
(flag-RD (if (even? flag) 0 1))
|
||||
(flag-shift (arithmetic-shift flag -2)))
|
||||
(append id (list (ascii->char
|
||||
(+ flag-RD (arithmetic-shift
|
||||
(+ (if bool 1 0)
|
||||
(arithmetic-shift flag-shift 1)) 1))))
|
||||
rest)))
|
||||
|
||||
|
||||
;; Interpreting the results of db-lookup-rec. Is there a zone in the db:
|
||||
;; TYPE: '(list-of-ans list-of-aut list-of-add boolean) -> boolean
|
||||
(define (no-zone? res-l)
|
||||
(and (null? (car res-l)) (null? (cadr res-l))
|
||||
(null? (caddr res-l)) (not (cadddr res-l))))
|
||||
|
||||
|
||||
;; A reply is chacheworthy if it contains no errors and is authoritative.
|
||||
;; TYPE: message -> boolean
|
||||
(define (msg-cachable? msg)
|
||||
(and (eq? 'dns-no-error (flags-response-code
|
||||
(header-flags (message-header msg))))
|
||||
(flags-authoritative? (header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; ------------
|
||||
;; --- AXFR ---
|
||||
;; ------------
|
||||
|
||||
;; AXFR is triggered by the zone-management-thread below:
|
||||
;; TYPE: rr x string x message-class x dnsd-options -> boolean
|
||||
(define (axfr-update soa-rr zone-name class dnsd-options dnsddb-options)
|
||||
|
||||
;; Search for the primary nameserver (msg) & get the soa-rr (msg2)
|
||||
;; TYPE: string x string x message-class x dnsd-options -> soa-rr x ns-ip
|
||||
(define (receive-soa-message ns-name name class dnsd-options dnsddb-options)
|
||||
(let* ((ip? (dnsddb-options-master-ip dnsddb-options))
|
||||
;; Lookup the IP or use dnsddb-options-master-ip
|
||||
(nameserver
|
||||
(if (and ip? (ip-string? ip?))
|
||||
(ip-string->address32 ip?)
|
||||
(let* ((msg (dnsd-ask-resolver-rec
|
||||
(make-simple-query-message ns-name
|
||||
(message-type a) class)
|
||||
(network-protocol udp) dnsd-options))
|
||||
(error-cond (flags-response-code
|
||||
(header-flags
|
||||
(message-header msg)))))
|
||||
(if (eq? 'dns-no-error error-cond)
|
||||
(resource-record-data-a-ip
|
||||
(resource-record-data
|
||||
(car (message-answers msg))))
|
||||
(begin
|
||||
(dnsd-log (syslog-level debug)
|
||||
"AXFR: Error (~S) during rec.-lookup for the address of the primary NS for zone ~S."
|
||||
error-cond
|
||||
name)
|
||||
#f))))))
|
||||
(if nameserver
|
||||
(let* ((msg2 (dnsd-ask-resolver-direct
|
||||
(make-simple-query-message name (message-type soa)
|
||||
class)
|
||||
(list nameserver) (network-protocol udp) dnsd-options))
|
||||
(error-cond (flags-response-code
|
||||
(header-flags (message-header msg2)))))
|
||||
(if (eq? 'dns-no-error error-cond)
|
||||
(values (car (message-answers msg2)) nameserver)
|
||||
(begin
|
||||
(dnsd-log (syslog-level debug)
|
||||
"AXFR: Error (~S) during rec.-lookup for the SOA-record of the primary NS for zone ~S."
|
||||
error-cond
|
||||
name)
|
||||
(values #f #f))))
|
||||
(values #f #f))))
|
||||
|
||||
;; Try to receive an zone with an AXFR-request:
|
||||
(define (receive-axfr-message name class nameserver dnsd-options)
|
||||
(let* ((msg (dnsd-ask-resolver-direct
|
||||
(make-simple-query-message name (message-type axfr) class)
|
||||
nameserver (network-protocol tcp) dnsd-options))
|
||||
(error-cond (flags-response-code (header-flags
|
||||
(message-header msg)))))
|
||||
(if (eq? error-cond 'dns-no-error)
|
||||
(message-answers msg)
|
||||
(begin
|
||||
(dnsd-log (syslog-level debug)
|
||||
"AXFR: Error (~S) during AXFR-request for zone ~S"
|
||||
error-cond
|
||||
name)
|
||||
#f))))
|
||||
|
||||
(let* ((soa-data (resource-record-data soa-rr))
|
||||
(zone-mname (resource-record-data-soa-mname soa-data))
|
||||
(zone-serial (resource-record-data-soa-serial soa-data)))
|
||||
(dnsd-log (syslog-level info)
|
||||
"AXFR: Starting AXFR-Update for zone ~S"
|
||||
(resource-record-name soa-rr))
|
||||
(receive
|
||||
(new-soa nameserver)
|
||||
(receive-soa-message zone-mname zone-name class dnsd-options dnsddb-options)
|
||||
(if (not new-soa)
|
||||
#f
|
||||
;; Compare the serials of the local and remote soa-rrs to decide
|
||||
;; if an update is neccessary.
|
||||
(if (< zone-serial (resource-record-data-soa-serial
|
||||
(resource-record-data new-soa)))
|
||||
;; Try an (AXFR)-Update...
|
||||
(let ((axfr-zone (receive-axfr-message zone-name class
|
||||
(list nameserver)
|
||||
dnsd-options)))
|
||||
(if axfr-zone
|
||||
(begin
|
||||
(let ((first (resource-record-data (car axfr-zone)))
|
||||
(last (resource-record-data
|
||||
(list-ref axfr-zone
|
||||
(- (length axfr-zone) 1)))))
|
||||
(if (and (resource-record-data-soa? first)
|
||||
(resource-record-data-soa? last))
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"AXFR: Received AXFR-Reply for zone ~S. Starting database-update."
|
||||
zone-name)
|
||||
(db-update-zone (cdr axfr-zone)))
|
||||
#f)))
|
||||
#f))
|
||||
#t)))))
|
||||
|
||||
|
||||
;; ---------------------------------------------
|
||||
;; --- Query-lookup in database and/or cache ---
|
||||
;; ---------------------------------------------
|
||||
|
||||
;; Currently supported types:
|
||||
;; TYPE: message-type -> boolean
|
||||
(define (dnsd-supported-type? type)
|
||||
(not (null? (filter (lambda (e) (eq? type e))
|
||||
(list (message-type a)
|
||||
(message-type ns)
|
||||
(message-type cname)
|
||||
(message-type soa)
|
||||
(message-type ptr)
|
||||
(message-type hinfo)
|
||||
(message-type mx)
|
||||
(message-type txt)
|
||||
(message-type axfr)
|
||||
(message-type mailb); Mailbox-related rrs. Here: mx
|
||||
(message-type *))))))
|
||||
|
||||
|
||||
;; TODO: Find out how to handle a standard query with multiple questions?
|
||||
;; Should that be allowed at all?
|
||||
|
||||
|
||||
;; Main algorithm for incoming queries. Responsibilities:
|
||||
;; - decides if the query-type is implemented
|
||||
;; - decides if and when to use cache/db-lookup/recursive lookup
|
||||
;; TYPE: message x dnsd-options -> message
|
||||
(define (lookup-query query dnsd-options)
|
||||
(let ((query-flags (header-flags (message-header query))))
|
||||
;; What OPCODE do we have here?
|
||||
(cond
|
||||
;; * [1] standard query (the only supported so far)
|
||||
((= 0 (flags-opcode query-flags))
|
||||
(let* ((question (car (message-questions query)))
|
||||
(qname (question-name question))
|
||||
(qclass (question-class question))
|
||||
(qtype (question-type question)))
|
||||
;; What kind of QTYPE do we have?
|
||||
(cond
|
||||
;; AXFR (252): A zone transfer... .
|
||||
((and (eq? (message-type axfr) qtype)
|
||||
(dnsd-options-use-axfr? dnsd-options))
|
||||
(let ((zone (db-get-zone-for-axfr qname qclass)))
|
||||
;; TODO: Is it okay to send the whole zone?
|
||||
;; Maybe there should be checked who is asking?
|
||||
(make-response query (list zone '() '() #t) dnsd-options)))
|
||||
;; Supported QTYPES:
|
||||
((dnsd-supported-type? qtype)
|
||||
;; Try to get a database reply
|
||||
(let ((res-l (if (dnsd-options-use-db? dnsd-options)
|
||||
(receive
|
||||
(anli auli adli aufl)
|
||||
(db-lookup-rec qname qclass qtype)
|
||||
(list anli auli adli aufl))
|
||||
(list '() '() '() #f))))
|
||||
;; Use recursion for local-result: '(() () () #f)
|
||||
(if (and (dnsd-options-use-recursion? dnsd-options)
|
||||
(no-zone? res-l)
|
||||
(flags-recursion-desired? query-flags))
|
||||
(dnsd-ask-resolver-rec query (network-protocol udp) dnsd-options)
|
||||
(make-response query res-l dnsd-options))))
|
||||
;; Unsupported QTYPEs:
|
||||
(else (msg-set-rcode! query 4) query))))
|
||||
;; This kind of queries are not implemented:
|
||||
;; * [2] inverse query (not really used anymore (see RFC 3425))
|
||||
;; * [3] server status request (marked experimental in RFC 1035)
|
||||
;; * [4-15] reserved for future use (RFC 1035)
|
||||
(else (msg-set-rcode! query 4) query))))
|
||||
|
||||
|
||||
;; --------------
|
||||
;; --- Server ---
|
||||
;; --------------
|
||||
|
||||
;; Management of a zone:
|
||||
;; ---------------------
|
||||
|
||||
;; Management consists of periodically checking the local files for
|
||||
;; new information for primary-zones and to trigger AXFR-Updates for secondary
|
||||
;; zones.
|
||||
;; TYPE channel x channel x dnsd-options x dnsddb-options -> new-thread
|
||||
(define (dnsd-zone-mgt-thread ch-usr1 ch-usr2 dnsd-options dnsddb-options)
|
||||
|
||||
(define (wait-thread zone-refresh ch-wakeup dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let ((refresh (* zone-refresh 1000)))
|
||||
(if (< refresh (dnsd-options-retry-interval dnsd-options))
|
||||
(sleep (dnsd-options-retry-interval dnsd-options))
|
||||
(sleep refresh))
|
||||
(sync (send-rv ch-wakeup #t))))))
|
||||
|
||||
(let* ((dnsd-options dnsd-options)
|
||||
(ch-wakeup (make-channel))
|
||||
(zone-name (dnsddb-options-name dnsddb-options))
|
||||
(type (dnsddb-options-type dnsddb-options))
|
||||
(primary? (or (string-ci=? type "master")
|
||||
(string-ci=? type "primary")))
|
||||
(class (dnsddb-options-class dnsddb-options)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let refresh-loop ()
|
||||
(let* ((soa-data (resource-record-data
|
||||
(db-get-zone-soa-rr zone-name class)))
|
||||
(zone-refresh (resource-record-data-soa-refresh soa-data))
|
||||
(retry-val (resource-record-data-soa-retry soa-data))
|
||||
(expire-val (resource-record-data-soa-expire soa-data)))
|
||||
;; Start thread for wakeup-channel:
|
||||
(wait-thread zone-refresh ch-wakeup dnsd-options)
|
||||
(let inner-loop ()
|
||||
(sync
|
||||
(choose
|
||||
;; Set new dnsd-options:
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (new-dnsd-options)
|
||||
(set! dnsd-options new-dnsd-options)
|
||||
(inner-loop)))
|
||||
;; Terminate the thread if a reload is signaled:
|
||||
(wrap (receive-rv ch-usr2)
|
||||
(lambda (ignore) #t))
|
||||
;; Try a refresh:
|
||||
(wrap (receive-rv ch-wakeup)
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Reloading zone ~S"
|
||||
zone-name)
|
||||
;; Primary or secondary zone?
|
||||
(if (if primary?
|
||||
(not
|
||||
(dnsd-reload-zone dnsd-options dnsddb-options))
|
||||
(axfr-update (db-get-zone-soa-rr zone-name class)
|
||||
zone-name class dnsd-options
|
||||
dnsddb-options))
|
||||
;; Case the refresh didn't work:
|
||||
(if (< expire-val 0)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Zone ~S expired. Deleting from db!"
|
||||
zone-name)
|
||||
(db-clear-zone zone-name class)
|
||||
(inner-loop)) ;; Wait for termination...
|
||||
(begin
|
||||
(set! expire-val (- expire-val retry-val))
|
||||
(wait-thread retry-val ch-wakeup dnsd-options)
|
||||
(set! retry-val (* 2 retry-val))
|
||||
(inner-loop)))
|
||||
(refresh-loop)))))))))))))
|
||||
|
||||
|
||||
;; Reload options from dnsd-options.scm:
|
||||
;; -------------------------------------
|
||||
|
||||
;; If an error occures (malformed file etc.) the old options are used as the
|
||||
;; return value.
|
||||
;; TYPE: dnsd-options -> dnsd-options
|
||||
(define (dnsd-reload-options dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while reloading dnsd-options.scm")
|
||||
;(dnsd-log (syslog-level debug)"Above condition is: ~A" condition)
|
||||
dnsd-options)
|
||||
(lambda ()
|
||||
(let ((path (dnsd-options-dir dnsd-options)))
|
||||
(dnsd-log (syslog-level info)
|
||||
"Reloading dnsd-options.scm with path: ~S"
|
||||
path)
|
||||
(let* ((port (if (file-name-directory? path)
|
||||
(open-input-file (string-append path "dnsd-options.scm"))
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad path (~S) in dnsd-options. Trying ./dnsd-options.scm"
|
||||
path)
|
||||
(open-input-file "./dnsd-options.scm"))))
|
||||
(options? (read port)))
|
||||
(close-input-port port)
|
||||
(make-options-from-list options? dnsd-options))))))
|
||||
|
||||
|
||||
;; (Re)load zones from dnsd-zones.scm:
|
||||
;; -----------------------------------
|
||||
|
||||
;; Make a fake secondary zone for the management thread:
|
||||
;; TYPE: dnsddb-options -> list-of-rrs
|
||||
(define (make-sec-zone dnsddb-options)
|
||||
(list
|
||||
(dns-rr-soa (dnsddb-options-name dnsddb-options)
|
||||
(message-class in)
|
||||
0
|
||||
(list
|
||||
(dnsddb-options-master-name dnsddb-options)
|
||||
"unknown.mail-adress."
|
||||
0 ;; smallest serial possible
|
||||
5 ;; fast first fetch
|
||||
(* 60 10) ;; fast retry
|
||||
(* 60 60 24 7) ;; expires
|
||||
0)))) ;; min TTL
|
||||
|
||||
|
||||
;; Reload a zone...
|
||||
;; TYPE: zone x string x dnsd-options -> boolean
|
||||
(define (dnsd-reload-zone dnsd-options dnsddb-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while reloading a zone.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
#f)
|
||||
(lambda ()
|
||||
(let* ((path (dnsd-options-dir dnsd-options))
|
||||
(file (dnsddb-options-file dnsddb-options))
|
||||
(zone-name (dnsddb-options-name dnsddb-options)))
|
||||
;; Handle secondary zones...
|
||||
(if (dnsddb-options-master-name dnsddb-options)
|
||||
(db-update-zone (make-sec-zone dnsddb-options))
|
||||
;; handle primary zones
|
||||
(and-let* ((zone-list (if (string-ci=?
|
||||
(dnsddb-options-filetype dnsddb-options)
|
||||
"rfc")
|
||||
(parse-mf file dnsd-options)
|
||||
(load (string-append path file))))
|
||||
(soa-zone-name (maybe-get-soa-rr-name zone-list)))
|
||||
(if (string-ci=? zone-name soa-zone-name)
|
||||
(db-update-zone zone-list)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Zone names doesn't fit between file (%S) and dnsd-zones (%S)"
|
||||
soa-zone-name zone-name)
|
||||
(error " ")))))))))
|
||||
|
||||
|
||||
;; Initialize // reload the zones which are defined in dnsd-zones.scm
|
||||
;; TYPE: channel x channel x dnsd-options -> unspecific
|
||||
(define (dnsd-reload-dnsd-zones ch-usr1 ch-usr2 dnsd-options)
|
||||
(let ((usr1-channel-list '())
|
||||
(usr2-channel-list '())
|
||||
(dnsd-options dnsd-options))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (new-dnsd-options)
|
||||
(set! dnsd-options new-dnsd-options)
|
||||
(for-each (lambda (e) (sync (send-rv e new-dnsd-options)))
|
||||
usr1-channel-list)
|
||||
(loop)))
|
||||
(wrap
|
||||
(receive-rv ch-usr2)
|
||||
(lambda (ignore)
|
||||
;; Terminate all old management-threads:
|
||||
(for-each (lambda (e) (sync (send-rv e 'terminate)))
|
||||
usr2-channel-list)
|
||||
(set! usr1-channel-list '())
|
||||
(set! usr2-channel-list '())
|
||||
;; Clear database:
|
||||
(db-clear-database)
|
||||
(if (dnsd-options-use-db? dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while reloading dnsd-zones.scm")
|
||||
#f)
|
||||
(lambda ()
|
||||
(let* ((path (dnsd-options-dir dnsd-options))
|
||||
(port (if (file-name-directory? path)
|
||||
(open-input-file
|
||||
(string-append path "dnsd-zones.scm"))
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad path (~S) in dnsd-zones. Trying ./dnsd-zones.scm"
|
||||
path)
|
||||
(open-input-file "./dnsd-zones.scm"))))
|
||||
(zone-l (read port)))
|
||||
(close-input-port port)
|
||||
(if (list? zone-l)
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(let ((dnsddb-options (make-db-options-from-list e))
|
||||
(ch-usr1-thread (make-channel))
|
||||
(ch-usr2-thread (make-channel)))
|
||||
(if (dnsd-reload-zone dnsd-options dnsddb-options)
|
||||
(begin
|
||||
(dnsd-zone-mgt-thread ch-usr1-thread
|
||||
ch-usr2-thread
|
||||
dnsd-options
|
||||
dnsddb-options)
|
||||
(set! usr1-channel-list
|
||||
(cons ch-usr1-thread
|
||||
usr1-channel-list))
|
||||
(set! usr2-channel-list
|
||||
(cons ch-usr2-thread
|
||||
usr2-channel-list))))))
|
||||
zone-l)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad sytax in dnsd-zones.scm.")
|
||||
#f)))))
|
||||
#f)
|
||||
(loop))))))))))
|
||||
|
||||
|
||||
;; Management of the datastructures (Cache / SLIST / Blacklist)
|
||||
;; ------------------------------------------------------------
|
||||
|
||||
;; Clean dnsd-cache/slist every now and then.
|
||||
;; TYPE: channel x dnsd-options -> unspecific
|
||||
(define (dnsd-management-thread ch-usr1 dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let ((ch-wait (make-channel))
|
||||
(dnsd-options dnsd-options))
|
||||
(let loop ()
|
||||
(let ((time-in-sec (dnsd-options-cleanup-interval dnsd-options)))
|
||||
;; Starting this thread to wait on ch-wait:
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(sleep (* time-in-sec 1000))
|
||||
(sync (send-rv ch-wait 'whatever))))
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-wait)
|
||||
(lambda (ignore)
|
||||
(if (dnsd-options-use-cache? dnsd-options)
|
||||
(dnsd-cache-clean!))
|
||||
(dnsd-slist-clean!)
|
||||
;; deprecated (dnsd-blacklist-clean! dnsd-options)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Cleaned CACHE and SLIST. Current interval is ~D seconds."
|
||||
time-in-sec)
|
||||
#t))
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (value) (set! dnsd-options value)))))
|
||||
(loop)))))))
|
||||
|
||||
|
||||
;; Pre- and post-processing of messages:
|
||||
;; -------------------------------------
|
||||
|
||||
(define (dnsd-pre message socket-addr dnsd-options)
|
||||
(dnsd-pre/post message socket-addr dnsd-options "dnsd-pre.scm"))
|
||||
|
||||
(define (dnsd-post message socket-addr dnsd-options)
|
||||
(dnsd-pre/post message socket-addr dnsd-options "dnsd-post.scm"))
|
||||
|
||||
;; Load the pre- and post-processing files...
|
||||
;; TYPE: msg x socket-addr x dnsd-options x string -> msg x dnsd-options
|
||||
(define (dnsd-pre/post message socket-addr dnsd-options file)
|
||||
(if (dnsd-options-use-pre/post dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(values message dnsd-options))
|
||||
(lambda ()
|
||||
(let* ((dir (dnsd-options-dir dnsd-options))
|
||||
(path (if (file-name-directory? dir)
|
||||
(string-append dir file)
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"Bad dir (~S) in options. Trying ./~S"
|
||||
dir file)
|
||||
(string-append "./" file)))))
|
||||
((load path) message socket-addr dnsd-options))))
|
||||
(values message dnsd-options)))
|
||||
|
||||
|
||||
;; UDP thread:
|
||||
;; -----------
|
||||
|
||||
;; Starts the main UDP-loop:
|
||||
;; TYPE: socket x channel x dnsd-options -> unspecific
|
||||
(define (dnsd-server-loop-udp socket ch-usr1 dnsd-options)
|
||||
(let ((ch-receive (make-channel))
|
||||
(max-con (make-semaphore (dnsd-options-max-connections dnsd-options)))
|
||||
(dnsd-options dnsd-options))
|
||||
;; Thread for incoming UDP-messages:
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a UDP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
;(loop))
|
||||
decline)
|
||||
(lambda ()
|
||||
(semaphore-wait max-con)
|
||||
(receive
|
||||
(msg addr)
|
||||
(receive-message/partial socket 512)
|
||||
(sync (send-rv ch-receive (cons msg addr)))
|
||||
(loop)))))))
|
||||
;; Choose between user-interrupt or query-processing
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-receive)
|
||||
(lambda (value)
|
||||
(udp-processing-thread (car value) (cdr value)
|
||||
socket max-con dnsd-options)))
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (value)
|
||||
(set! dnsd-options value)
|
||||
(set-semaphore! max-con (dnsd-options-max-connections
|
||||
dnsd-options))))))
|
||||
(loop))))))
|
||||
|
||||
|
||||
;; Start the thread for processing a UDP-query.
|
||||
;; TYPE: message x address x socket x dnsd-options -> unspecific
|
||||
(define (udp-processing-thread msg addr socket max-con dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a UDP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
(semaphore-post max-con)
|
||||
;#f)
|
||||
decline)
|
||||
(lambda ()
|
||||
(let ((msg (parse (string->list msg))))
|
||||
(if (not msg)(error "Couldn't parse the message."))
|
||||
;; Preprocess the message...
|
||||
(receive
|
||||
(msg dnsd-options)
|
||||
(dnsd-pre msg addr dnsd-options)
|
||||
(if (not msg) (semaphore-post max-con)
|
||||
(let* ((msg-header (message-header msg))
|
||||
(msg-flags (header-flags msg-header))
|
||||
(msg-trunc? (flags-truncated? msg-flags)))
|
||||
(if msg-trunc? (error "Couldn't process truncated query."))
|
||||
(let ((reply (lookup-query msg dnsd-options)))
|
||||
(if (not reply) (error "Lookup produced no reply."))
|
||||
;; Postprocessing the message:
|
||||
(receive
|
||||
(reply dnsd-options)
|
||||
(dnsd-post reply addr dnsd-options)
|
||||
(if (not reply) (semaphore-post max-con)
|
||||
(let* ((octet-list (mc-message->octets reply))
|
||||
(l (length octet-list)))
|
||||
(if (> l 512) ; Use message-truncation?
|
||||
(let* ((msg (octet-msg-change-truncation
|
||||
octet-list #t))
|
||||
(to-send (list->string (take msg 512))))
|
||||
(receive
|
||||
(host-addr port)
|
||||
(socket-address->internet-address addr)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Sending truncated UDP-response to: ~A"
|
||||
(address32->ip-string host-addr))
|
||||
(send-message socket to-send 0 511 0 addr)))
|
||||
(begin
|
||||
(send-message socket (list->string octet-list)
|
||||
0 l 0
|
||||
addr)))
|
||||
(semaphore-post max-con))))))))))))))
|
||||
|
||||
|
||||
|
||||
;; TCP thread:
|
||||
;; -----------
|
||||
|
||||
;; Main TCP-loop:
|
||||
;; TYPE: socket x channel x dnsd-options -> unspecific
|
||||
(define (dnsd-server-loop-tcp socket ch-usr1 dnsd-options)
|
||||
(let ((ch-receive (make-channel))
|
||||
(max-con (make-semaphore (dnsd-options-max-connections dnsd-options)))
|
||||
(dnsd-options dnsd-options))
|
||||
;; Thread for incoming TCP-messages:
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a TCP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
(loop))
|
||||
;decline)
|
||||
(lambda ()
|
||||
(semaphore-wait max-con)
|
||||
(receive
|
||||
(private-socket addr)
|
||||
(accept-connection socket)
|
||||
(sync (send-rv ch-receive (cons private-socket addr)))
|
||||
(loop)))))))
|
||||
;; Choose between user-interrupt or query-processing
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(let loop ()
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-receive)
|
||||
(lambda (value)
|
||||
(tcp-processing-thread (car value) (cdr value)
|
||||
max-con dnsd-options)))
|
||||
(wrap (receive-rv ch-usr1)
|
||||
(lambda (value)
|
||||
(set! dnsd-options value)
|
||||
(set-semaphore! max-con (dnsd-options-max-connections
|
||||
dnsd-options))))))
|
||||
(loop))))))
|
||||
|
||||
|
||||
;; Start the thread for processing a TCP-query:
|
||||
;; TYPE: address x socket x dnsd-options -> unspecific
|
||||
(define (tcp-processing-thread socket addr max-con dnsd-options)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while processing a TCP-query.")
|
||||
;(dnsd-log (syslog-level debug) "Above condition is: ~A" condition)
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket) #f)
|
||||
(lambda ()
|
||||
(let* ((inport (socket:inport socket))
|
||||
(outport (socket:outport socket))
|
||||
;; A tcp-message has a 2-octet-length size tag:
|
||||
(front (read-char inport))
|
||||
(rear (read-char inport))
|
||||
(size-tag (octet-pair->number front rear))
|
||||
(octet-msg (read-string size-tag inport))
|
||||
(msg (parse (string->list octet-msg))))
|
||||
(if (not msg)(error "Couldn't parse the message"))
|
||||
;; Preprocessing:
|
||||
(receive
|
||||
(msg dnsd-options)
|
||||
(dnsd-pre msg addr dnsd-options)
|
||||
(if (not msg)
|
||||
(begin
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket))
|
||||
(let* ((msg-header (message-header msg))
|
||||
(msg-flags (header-flags msg-header))
|
||||
(msg-trunc? (flags-truncated? msg-flags)))
|
||||
(if msg-trunc? (error "Couldn't process truncated query."))
|
||||
(let ((reply (lookup-query msg dnsd-options)))
|
||||
(if (not reply) (error "Lookup produced no reply."))
|
||||
;; Postprocessing:
|
||||
(receive
|
||||
(reply dnsd-options)
|
||||
(dnsd-post reply addr dnsd-options)
|
||||
(if (not reply)
|
||||
(begin
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket))
|
||||
(let* ((reply (mc-message->octets reply))
|
||||
(l (number->octet-pair (length reply))))
|
||||
(write-string (list->string (append l reply)) outport)
|
||||
(semaphore-post max-con)
|
||||
(close-socket socket))))))))))))))
|
||||
|
||||
|
||||
;; Initialize and start UDP and TCP threads:
|
||||
;; TYPE: dnsd-options -> unspecific
|
||||
(define (init-dnsd dnsd-options)
|
||||
(let ((ch-usr1-udp (make-channel))
|
||||
(ch-usr1-tcp (make-channel))
|
||||
(ch-usr1-mgt (make-channel))
|
||||
(ch-usr1-zones (make-channel))
|
||||
(ch-usr2-zones (make-channel))
|
||||
(dnsd-options dnsd-options))
|
||||
(call-with-current-continuation
|
||||
(lambda (escape)
|
||||
;; Maybe load the options from file:
|
||||
(set! dnsd-options (dnsd-reload-options dnsd-options))
|
||||
;; Initializing signal-handler(s)
|
||||
;; * USR1 (reload dnsd-options.scm)
|
||||
;; Log debug-level in syslog?
|
||||
(with-syslog-destination
|
||||
(string-append "dnsd (" (number->string (pid)) ")")
|
||||
#f
|
||||
#f
|
||||
(if (dnsd-options-debug-mode dnsd-options)
|
||||
(syslog-mask-upto (syslog-level info))
|
||||
#f)
|
||||
(lambda ()
|
||||
(set-interrupt-handler
|
||||
interrupt/usr1
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Interrupt/USR1: Reloading options.")
|
||||
(set! dnsd-options (dnsd-reload-options dnsd-options))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-udp dnsd-options))))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-tcp dnsd-options))))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-mgt dnsd-options))))
|
||||
(fork-thread
|
||||
(lambda () (sync (send-rv ch-usr1-zones dnsd-options))))))
|
||||
;; * USR2 (reload dnsd-zones.scm)
|
||||
(set-interrupt-handler
|
||||
interrupt/usr2
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Interrupt/USR2: Reloading zones.")
|
||||
(sync (send-rv ch-usr2-zones 'ignore))))
|
||||
;; Initializing cleanup thread:
|
||||
(dnsd-management-thread ch-usr1-mgt dnsd-options)
|
||||
;; Initialize & load the database:
|
||||
(dnsd-reload-dnsd-zones ch-usr1-zones ch-usr2-zones dnsd-options)
|
||||
(sync (send-rv ch-usr2-zones 'ignore))
|
||||
;; Initializing tcp/upd sockets & start thread:
|
||||
(let* ((the-port (dnsd-options-port dnsd-options))
|
||||
(udp-socket (create-socket protocol-family/internet
|
||||
socket-type/datagram))
|
||||
(tcp-socket (create-socket protocol-family/internet
|
||||
socket-type/stream))
|
||||
(socket-addr (internet-address->socket-address
|
||||
internet-address/any the-port)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Coudn't start dnsd. Port ~D is already in use."
|
||||
the-port)
|
||||
(close-socket udp-socket)
|
||||
(close-socket tcp-socket)
|
||||
(escape 'douh!))
|
||||
(lambda ()
|
||||
(dnsd-log (syslog-level info)
|
||||
"Starting the service on port: ~D"
|
||||
the-port)
|
||||
(bind-socket udp-socket socket-addr)
|
||||
(bind-socket tcp-socket socket-addr)
|
||||
(listen-socket tcp-socket 10))) ; TODO: How big should the queue be?
|
||||
;; Start the UDP-Loop:
|
||||
(fork-thread (lambda () (dnsd-server-loop-udp udp-socket ch-usr1-udp
|
||||
dnsd-options)))
|
||||
;; Start the TCP-Loop:
|
||||
(fork-thread (lambda () (dnsd-server-loop-tcp tcp-socket ch-usr1-tcp
|
||||
dnsd-options))))))))))
|
||||
|
||||
;; Entry-Point for run-dnsd
|
||||
;; ------------------------
|
||||
|
||||
(define (dnsd-start . dir)
|
||||
(with-syslog-destination
|
||||
(string-append "dnsd (" (number->string (pid)) ")") #f #f #f
|
||||
(lambda ()
|
||||
(if (null? dir)
|
||||
(init-dnsd (make-default-dnsd-options))
|
||||
(init-dnsd (with-dir
|
||||
(file-name-as-directory (car dir))
|
||||
(make-default-dnsd-options)))))))
|
||||
|
||||
|
|
@ -1,103 +0,0 @@
|
|||
;; Option-File for DNSD:
|
||||
;; ---------------------
|
||||
|
||||
;; Options can be reloaded using the POSIX-Signal USR1.
|
||||
|
||||
|
||||
;; External option representation <datum>:
|
||||
;; ---------------------------------------
|
||||
|
||||
;; (options
|
||||
;; [dir string]
|
||||
;; [nameservers list-of-ip-strings]
|
||||
;; [use-axfr boolean]
|
||||
;; [use-cache boolean]
|
||||
;; [cleanup-interval time-in-sec]
|
||||
;; [retry-interval time-in-sec]
|
||||
;; [use-db boolean]
|
||||
;; [use-recursion boolean]
|
||||
;; [rec-timeout time-in-s]
|
||||
;; [socket-timeout time-in-s]
|
||||
;; [socket-max-tries integer]
|
||||
;; [max-connections integer]
|
||||
;; [blacklist-time time-in-s]
|
||||
;; [blacklist-value integer]
|
||||
;; [use-pre/post boolean])
|
||||
|
||||
;; [...] indicates an optional list.
|
||||
|
||||
|
||||
;; Semantic:
|
||||
;; ---------
|
||||
|
||||
;; (dir string)
|
||||
;; Path to the directory with this configuration files.
|
||||
;; Standard value is "." - the dir where dnsd was started or the
|
||||
;; directory which was passed to (dnsd-start <optional-dir>)
|
||||
|
||||
;; (nameservers list-of-ip-strings)
|
||||
;; A list of nameserver-IPs used for recursive lookups.
|
||||
;; Standard value is a list of root-nameservers.
|
||||
|
||||
;; (use-axfr boolean)
|
||||
;; Toggles to answer to axfr-requests. Default value is #t.
|
||||
|
||||
;; (use-cache boolean)
|
||||
;; Toggles caching of responses. Default value is #t.
|
||||
|
||||
;; (cleanup-interval time-in-sec)
|
||||
;; Clean the cache and slist after X seconds. Default value is 1h.
|
||||
|
||||
;; (retry-interval time-in-sec)
|
||||
;; Minimum value in seconds to trigger zone-reloads. This can override
|
||||
;; the value of some masterfiles. Default value is 1h.
|
||||
|
||||
;; (use-db boolean boolean)
|
||||
;; Toggle the usage of the local database. Default value is on - #t.
|
||||
|
||||
;; (use-recursion boolean)
|
||||
;; Switch the recursive-lookup on/off. Default value is on - #t.
|
||||
|
||||
;; (rec-timeout time-in-sec)
|
||||
;; Global timeout for a recursive lookup. Default is 10 seconds.
|
||||
|
||||
;; (socket-timeout time-in-sec)
|
||||
;; Timeout for one lookup during a recursive lookup. Default is 2 seconds.
|
||||
|
||||
;; (socket-max-tries integer)
|
||||
;; Maximum nuber of tries to establish a connection for recursive lookups.
|
||||
;; Default value is 3.
|
||||
|
||||
;; (max-connection integer)
|
||||
;; Maximum concurrent connections for each UDP and TCP. Default is 25.
|
||||
|
||||
;; (blacklist-time time-in-sec)
|
||||
;; How long will a bad NS be blacklisted/not used? Default is 30 min.
|
||||
|
||||
;; (blacklist-value integer)
|
||||
;; How often, before a bad NS will be ignored? Default is 5 times.
|
||||
|
||||
;; (use-pre/post boolean)
|
||||
;; Toggles load of pre- and post-processing files. Default is off - #f.
|
||||
|
||||
;; all args are optional. If not given, the def. value will be used.
|
||||
|
||||
|
||||
;; Some examples:
|
||||
;; --------------
|
||||
;;
|
||||
;; (options (nameservers ("192.168.2.1" "192.168.2.2"))
|
||||
;; (use-axfr #t)
|
||||
;; (use-cache #t)
|
||||
;; (cleanup-interval 666)
|
||||
;; (use-recursion #t)
|
||||
;; (use-db #f)
|
||||
;; (use-pre/post #f))
|
||||
;;
|
||||
;; (options) == use the default values.
|
||||
;;
|
||||
|
||||
;; OPTION-DEFINITIONS:
|
||||
|
||||
(options)
|
||||
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(lambda (msg socket-addr dnsd-options)
|
||||
(display "Postprocessing works.")
|
||||
(values msg dnsd-options))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(lambda (msg socket-addr dnsd-options)
|
||||
(display "Preprocessing works.")
|
||||
(values msg dnsd-options))
|
||||
|
|
@ -1,80 +0,0 @@
|
|||
;; Zones-File for DNSD:
|
||||
;; --------------------
|
||||
|
||||
;; The local zones of the NS can be reloaded using the
|
||||
;; POSIX signal USR2.
|
||||
|
||||
|
||||
;; External zones representation <datum>:
|
||||
;; --------------------------------------
|
||||
|
||||
;; zone-file ::= list-of-zone-lists
|
||||
|
||||
;; list-of-zone ::= primary-zone | secondary-zone
|
||||
|
||||
;; primary-zone ::= (zone (name string)
|
||||
;; (type "master" or "primary")
|
||||
;; (file string)
|
||||
;; [filetype string])
|
||||
|
||||
;; secondary-zone ::= (zone (name string)
|
||||
;; (type "slave" or "secondary")
|
||||
;; (master-name string)
|
||||
;; [master-ip ip-string])
|
||||
|
||||
|
||||
|
||||
;; [...] is an optional list.
|
||||
|
||||
|
||||
;; Semantic:
|
||||
;; ---------
|
||||
|
||||
;; list-of-zone-lists
|
||||
;; A list containing all zones of the NS.
|
||||
|
||||
;; list-of-zone
|
||||
;; A list containing the options for one zone of the NS.
|
||||
|
||||
;; (name string)
|
||||
;; The fully-qualified-domain-name of the zone.
|
||||
|
||||
;; (type "master" or "slave")
|
||||
;; The type of the zone. One of the two strings: "master" or "slave".
|
||||
;; Alternatively, it can be "primary" or "secondary".
|
||||
|
||||
;; (file string)
|
||||
;; The filename of the masterfile.
|
||||
|
||||
;; (filetype string)
|
||||
;; One of the two strings "dnsd" or "rfc". Default is "dnsd".
|
||||
|
||||
;; (master-name string)
|
||||
;; The domain-name of the master-nameserver.
|
||||
|
||||
;; (master-ip ip-string)
|
||||
;; The IP of the master-nameserver. If non given, DNSD will try to
|
||||
;; lookup the IP.
|
||||
|
||||
|
||||
;; Examples:
|
||||
;; --------
|
||||
|
||||
;; () == No zones given. Use dnsd as a resolver only.
|
||||
;;
|
||||
;; Try the examples and be a secondary NS for the domain "porsche.de"
|
||||
;;
|
||||
;;((zone (name "my.example.")
|
||||
;; (type "master")
|
||||
;; (file "zone-example-scheme"))
|
||||
;; (zone (name "example.com.")
|
||||
;; (type "master")
|
||||
;; (file "zone-example-rfc")
|
||||
;; (filetype "rfc")))
|
||||
;; (zone (name "porsche.de.")
|
||||
;; (type "slave")
|
||||
;; (master-name "dns01.fw.porsche.de."))
|
||||
|
||||
;; DEFINE HERE:
|
||||
|
||||
()
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
$ORIGIN example.com.
|
||||
$TTL 2D
|
||||
example.com. IN SOA gateway root.example.com. (
|
||||
2003072441 ; serial
|
||||
1D ; refresh
|
||||
2H ; retry
|
||||
1W ; expiry
|
||||
2D ) ; minimum
|
||||
|
||||
IN NS gateway
|
||||
IN MX 10 sun
|
||||
|
||||
gateway IN A 192.168.0.1
|
||||
IN A 192.168.1.1
|
||||
sun IN A 192.168.0.2
|
||||
moon IN A 192.168.0.3
|
||||
earth IN A 192.168.1.2
|
||||
mars IN A 192.168.1.3
|
||||
www IN CNAME venus
|
||||
|
||||
; A cname-loop...
|
||||
|
||||
venus IN CNAME saturn
|
||||
saturn IN CNAME venus
|
||||
|
||||
; Glue Data
|
||||
|
||||
nofreude IN NS ns1.nofreude
|
||||
|
||||
ns1.nofreude IN A 192.168.2.66
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
; Zone-example using the functions from dnsd/rr-def.scm and lib/dns.scm
|
||||
; ---------------------------------------------------------------------
|
||||
|
||||
(let ((mc (message-class in))
|
||||
(ttl (* 60 60 24)))
|
||||
(list
|
||||
(dns-rr-soa "my.example." mc ttl
|
||||
(list "nameserver.my.example." "webmaster.my.example"
|
||||
20051203 7200 600 300000 1111))
|
||||
(dns-rr-a "my.example." mc ttl "192.168.2.1")
|
||||
(dns-rr-ns "my.example." mc ttl "nameserver.my.example.")
|
||||
(dns-rr-a "on.my.example." mc ttl "192.168.2.2")
|
||||
(dns-rr-a "*.my.example." mc ttl "192.168.2.3")
|
||||
(dns-rr-mx "my.example" mc ttl (list 11 "mx.my.example"))
|
||||
(dns-rr-cname "cname.my.example" mc ttl "my.example")
|
||||
(dns-rr-a "mx.my.example" mc ttl "192.168.2.4")
|
||||
(dns-rr-ns "ns.my.example" mc ttl "ns.test.")
|
||||
(dns-rr-ns "more.my.example" mc ttl "ns2.my.example")
|
||||
(dns-rr-a "ns2.my.example" mc ttl "192.168.2.11")))
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
; ------------------------
|
||||
; --- Syslog-Interface ---
|
||||
; ------------------------
|
||||
|
||||
; Syslog/Debug-Stuff for dnsd.
|
||||
|
||||
; This file is (maybe) part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
|
||||
(define *debug-info* #f) ; switch debug-information on/off
|
||||
|
||||
;; TODO: log-file instead of display-information:
|
||||
|
||||
;; Show some debug-information
|
||||
(define display-debug
|
||||
(lambda args
|
||||
(if *debug-info*
|
||||
(begin
|
||||
(display "dnsd: ")
|
||||
(map (lambda (e) (display e) (display " ")) args)
|
||||
(newline))
|
||||
#f)))
|
||||
|
||||
(define (apply-w/debug proc . args)
|
||||
(if *debug-info* (apply proc args)))
|
||||
|
||||
(define (dnsd-log log-level msg . args)
|
||||
(syslog log-level (apply format #f msg args)))
|
||||
|
|
@ -1,369 +0,0 @@
|
|||
; -------------------------
|
||||
; --- Masterfile-Parser ---
|
||||
; -------------------------
|
||||
|
||||
; Parser for Masterfiles based on the RFCs: 1034 / 1035 / 2308 and
|
||||
; the BIND-Time-Value-Format convention.
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
|
||||
; Interface:
|
||||
; ----------
|
||||
|
||||
; (parse-mf fileaname dnsd-options) -> list-of-resource-records
|
||||
|
||||
|
||||
;; Lexer:
|
||||
;; ------
|
||||
|
||||
;; The lexer was generated using SILex v1.0 by Danny Dubé with
|
||||
;; specification file "masterfile.l"
|
||||
;; For more information about SILex visit: http://www.iro.umontreal.ca/~dube/
|
||||
;; TYPE: filename x dnsd-options -> list-of-lexems or #f
|
||||
(define (lex-masterfile file dnsd-options)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Error while parsing the file ~S"
|
||||
file)
|
||||
(dnsd-log (syslog-level debug)
|
||||
"Above condition is: ~A"
|
||||
condition)
|
||||
#f)
|
||||
(lambda ()
|
||||
(and-let* ((the-path (string-append (dnsd-options-dir dnsd-options) file))
|
||||
(whatever (file-name-non-directory? the-path))
|
||||
(the-port (open-input-file the-path)))
|
||||
(lexer-init 'port the-port)
|
||||
(let loop ((l '()))
|
||||
(let ((lexem (lexer)))
|
||||
(if (eq? lexem 'eof)
|
||||
(begin
|
||||
(close-input-port the-port)
|
||||
(reverse (cons lexem l)))
|
||||
(loop (cons lexem l)))))))))
|
||||
|
||||
|
||||
;; Parser:
|
||||
;; -------
|
||||
|
||||
;; Maybe append a domain-origin to a string:
|
||||
;; TYPE: dn-label-string x fqdn-string -> fqdn-string
|
||||
(define (parse-mf-maybe-append-origin name origin)
|
||||
(let ((l (string-length name)))
|
||||
(if (and (not (= 0 l)) (not (char=? #\. (string-ref name (- l 1)))))
|
||||
(if (string=? origin ".")
|
||||
(string-append name origin)
|
||||
(string-append name "." origin))
|
||||
name)))
|
||||
|
||||
|
||||
;; Parse (or restore) the name of the current line:
|
||||
;; TYPE: dn-label-string or symbol x fqdn-string x dn-label-string ->
|
||||
;; fqdn x dn-label-string
|
||||
(define (parse-mf-node-name? elem origin last-name)
|
||||
(cond
|
||||
((eq? elem 'origin-ref) (values origin origin)) ; @ in the masterfile
|
||||
((eq? elem 'blank) ; no name given - use last one
|
||||
(values (parse-mf-maybe-append-origin last-name origin) last-name))
|
||||
(else (values (parse-mf-maybe-append-origin elem origin) elem))))
|
||||
|
||||
|
||||
;; Parse the type of a rr-line:
|
||||
;; TYPE: string -> message-type
|
||||
(define (parse-mf-type? elem)
|
||||
(message-type-symbol->type (string->symbol (string-downcase elem))))
|
||||
|
||||
|
||||
;; Parse the class of a rr-line:
|
||||
;; TYPE: string -> message-class
|
||||
(define (parse-mf-class? elem)
|
||||
(message-class-symbol->type (string->symbol (string-downcase elem))))
|
||||
|
||||
|
||||
;; Parse a RFC-time value or a BIND-Masterfiles value: #w#d#h#m#s
|
||||
;; eg. 1 Week = 1w or 1d20s = 1 day and 20 seconds
|
||||
;; This algorithm is very liberal - a possible value would be 12s1d1w1s
|
||||
;; TYPE: string -> number
|
||||
(define (parse-mf-time-value? elem)
|
||||
(let loop ((str elem)
|
||||
(counter 0)
|
||||
(val 0))
|
||||
(let ((l (string-length str)))
|
||||
(if (= l 0)
|
||||
val
|
||||
(let ((sub (substring str counter (+ counter 1))))
|
||||
(if (string->number sub)
|
||||
(if (= counter (- l 1))
|
||||
(string->number str) ; original RFC format
|
||||
(loop str (+ counter 1) val))
|
||||
(let ((val2 (string->number (substring str 0 counter)))
|
||||
(rest-string (substring str (+ counter 1) l)))
|
||||
(cond
|
||||
((string-ci=? sub "w")
|
||||
(loop rest-string 0 (+ val (* 7 24 60 60 val2))))
|
||||
((string-ci=? sub "d")
|
||||
(loop rest-string 0 (+ val (* 24 60 60 val2))))
|
||||
((string-ci=? sub "h")
|
||||
(loop rest-string 0 (+ val (* 60 60 val2))))
|
||||
((string-ci=? sub "m")
|
||||
(loop rest-string 0 (+ val (* 60 val2))))
|
||||
((string-ci=? sub "s")
|
||||
(loop rest-string 0 (+ val val2)))
|
||||
(else
|
||||
(display elem)
|
||||
(error "Wrong time-value format"))))))))))
|
||||
|
||||
|
||||
;; Parse a rr-line:
|
||||
;; Syntax: {<domain>|@|<blank>} [<ttl>] [<class>] <type> <rdata>
|
||||
;; The algorithm has to guess serveral times which value actually
|
||||
;; is been parsed.
|
||||
;; TYPE: rr-line-of-lexems x fqdn x dn-string x ttl-number
|
||||
;; -> '(name ttl class type rdata origin) x fqdn x dn-string x ttl-number
|
||||
(define (parse-mf-rr line origin current-rr-name the-ttl)
|
||||
(receive
|
||||
(rr-name current-rr-name)
|
||||
(parse-mf-node-name? (car line) origin current-rr-name)
|
||||
(let* ((sec (cadr line))
|
||||
(type (parse-mf-type? sec)))
|
||||
(if type ; Parsing the type?
|
||||
(values (list rr-name the-ttl #f type (cddr line) origin)
|
||||
origin current-rr-name the-ttl)
|
||||
(let ((class (parse-mf-class? sec)))
|
||||
(if class ; Parsing a class?
|
||||
(let ((type (parse-mf-type? (caddr line))))
|
||||
(values (list rr-name the-ttl class type (cdddr line) origin)
|
||||
origin current-rr-name the-ttl))
|
||||
(let ((ttl (parse-mf-time-value? sec)))
|
||||
(if ttl ; Now it should be a TTL.
|
||||
(let* ((third (caddr line))
|
||||
(type (parse-mf-type? third)))
|
||||
(if type
|
||||
(values
|
||||
(list rr-name ttl #f type (cdddr line) origin)
|
||||
origin current-rr-name the-ttl)
|
||||
(let ((type (parse-mf-type? (cadddr line))))
|
||||
(values
|
||||
(list
|
||||
rr-name ttl (parse-mf-class? third) type
|
||||
(cdr (cdddr line)) origin)
|
||||
origin current-rr-name the-ttl))))
|
||||
(begin
|
||||
(display line)
|
||||
(error "Parsed a bad line!"))))))))))
|
||||
|
||||
|
||||
|
||||
;; Parse a masterfile-line:
|
||||
;;<line> ::= $ORIGIN <domain-name>
|
||||
;; | $INCLUDE ...
|
||||
;; | $TTL <number> (defined in RFC 2308)
|
||||
;; | <resource-record>
|
||||
;; TODO: | $GENERATE ... BIND-Version 9
|
||||
;;
|
||||
;; TYPE: mf-line x fqdn x dn-string x ttl-number x dnsd-options
|
||||
;; -> symbol or list-of-a-rr x fqdn x dn-string x ttl-number
|
||||
(define (parse-mf-line line origin current-rr-name ttl dnsd-options)
|
||||
(let ((first (car line)))
|
||||
(cond
|
||||
;; $INCLUDE
|
||||
((eq? first 'include)
|
||||
(let* ((file-name (cadr line))
|
||||
(maybe-origin (if (= (length line) 3) (caddr line) #f))
|
||||
(lexed-file (lex-masterfile file-name dnsd-options))
|
||||
(line-list (parse-mf-lex->lines lexed-file))
|
||||
(res (parse-mf-lexem-list
|
||||
line-list (if maybe-origin maybe-origin origin)
|
||||
current-rr-name #f dnsd-options)))
|
||||
(values res origin current-rr-name ttl)))
|
||||
;; $ORIGIN
|
||||
((eq? first 'origin)
|
||||
(let ((new-origin (cadr line)))
|
||||
(values 'ORIGIN
|
||||
(parse-mf-maybe-append-origin new-origin origin)
|
||||
current-rr-name ttl)))
|
||||
;; $TTL <number>
|
||||
((eq? first 'ttl)
|
||||
(let ((new-ttl (cadr line)))
|
||||
(values 'TTL origin current-rr-name (parse-mf-time-value? new-ttl))))
|
||||
;; $GENERATE ...
|
||||
((eq? first 'generate)
|
||||
(error "parse-masterfile: GENERATE is not supported."))
|
||||
; <resource-record>
|
||||
(else (parse-mf-rr line origin current-rr-name ttl)))))
|
||||
|
||||
|
||||
;; Transforms the lexer-output into a list of lines:
|
||||
;; TYPE: list-of-lexems -> list-of-lexem-lists
|
||||
(define (parse-mf-lex->lines lex-list)
|
||||
(let loop ((l lex-list)
|
||||
(line '())
|
||||
(ignore-line #f) ; Toggle comments.
|
||||
(res '()))
|
||||
(let ((first (car l)))
|
||||
(cond
|
||||
((eq? first 'eof)
|
||||
(if (null? line)
|
||||
(reverse res)
|
||||
(reverse (cons line res))))
|
||||
((eq? first 'left-par) ; Ignore line-breaks.
|
||||
(loop (cdr l) line #t res))
|
||||
((eq? first 'right-par) ; Consider line-breaks.
|
||||
(loop (cdr l) line #f res))
|
||||
((eq? first 'newline)
|
||||
(if (not ignore-line)
|
||||
(if (null? line)
|
||||
(loop (cdr l) '() ignore-line res)
|
||||
(loop (cdr l) '() ignore-line (cons line res)))
|
||||
(loop (cdr l) line ignore-line res)))
|
||||
((eq? first 'blank-newline)
|
||||
(if (not ignore-line)
|
||||
(if (null? line)
|
||||
(loop (cdr l) (list 'blank) ignore-line res)
|
||||
(loop (cdr l) (list 'blank) ignore-line (cons line res)))
|
||||
(loop (cdr l) line ignore-line res)))
|
||||
(else
|
||||
(loop (cdr l) (append line (list first)) ignore-line res))))))
|
||||
|
||||
|
||||
;; Actually create a resourc-record from the parsed rr-line:
|
||||
;; TYPE: '(name ttl class type rdata origin) -> resource-record-data
|
||||
(define (parse-mf-create-rr line)
|
||||
(let ((class (caddr line))
|
||||
(type (cadddr line)))
|
||||
(if (not (eq? (message-class in) class))
|
||||
(begin
|
||||
(display "Message-class not supported: ")
|
||||
(display class)
|
||||
(newline))
|
||||
(let ((name (car line))
|
||||
(ttl (cadr line))
|
||||
(data (list-ref line 4))
|
||||
(origin (list-ref line 5)))
|
||||
(cond
|
||||
((eq? type (message-type a))
|
||||
(dns-rr-a name class ttl (car data)))
|
||||
((eq? type (message-type ns))
|
||||
(dns-rr-ns name class ttl
|
||||
(parse-mf-maybe-append-origin (car data) origin)))
|
||||
((eq? type (message-type cname))
|
||||
(dns-rr-cname name class ttl
|
||||
(parse-mf-maybe-append-origin (car data) origin)))
|
||||
((eq? type (message-type soa))
|
||||
(and-let* ((mname (parse-mf-maybe-append-origin (car data) origin))
|
||||
(rname (parse-mf-maybe-append-origin (cadr data) origin))
|
||||
(serial (string->number (caddr data)))
|
||||
(refresh (parse-mf-time-value? (cadddr data)))
|
||||
(retry (parse-mf-time-value? (list-ref data 4)))
|
||||
(expire (parse-mf-time-value? (list-ref data 5)))
|
||||
(minimum (parse-mf-time-value? (list-ref data 6))))
|
||||
(dns-rr-soa name class ttl
|
||||
(list mname rname serial
|
||||
refresh retry expire minimum))))
|
||||
((eq? type (message-type ptr))
|
||||
(dns-rr-ptr name class ttl
|
||||
(parse-mf-maybe-append-origin (car data) origin)))
|
||||
((eq? type (message-type hinfo))
|
||||
(dns-rr-hinfo name class ttl data))
|
||||
((eq? type (message-type mx))
|
||||
(let ((pref (string->number (car data)))
|
||||
(exchange (parse-mf-maybe-append-origin (cadr data) origin)))
|
||||
(dns-rr-mx name class ttl (list pref exchange))))
|
||||
((eq? type (message-type txt))
|
||||
(dns-rr-txt name class ttl data))
|
||||
((eq? type (message-type aaaa))
|
||||
(dns-rr-aaaa name class ttl (car data)))
|
||||
(else #f))))))
|
||||
|
||||
|
||||
;; Parse the list-of-lexems and return a list of resource-records:
|
||||
;; TYPE: list-of-lexems x fqdn x dn-string x ttl-number x dnsd-options
|
||||
;; -> list-of-resource-records
|
||||
(define (parse-mf-lexem-list l origin current-rr-name ttl dnsd-options)
|
||||
(let loop ((l l)
|
||||
(res '())
|
||||
(origin origin)
|
||||
(current-rr-name current-rr-name)
|
||||
(ttl ttl))
|
||||
(if (null? l)
|
||||
res
|
||||
(receive (next-res origin current-rr-name ttl)
|
||||
(parse-mf-line (car l) origin current-rr-name ttl
|
||||
dnsd-options)
|
||||
(cond
|
||||
((or (eq? next-res 'ORIGIN)
|
||||
(eq? next-res 'TTL))
|
||||
(loop (cdr l) res origin current-rr-name ttl))
|
||||
((and (list? next-res) ; result from INCLUDE...
|
||||
(list? (car next-res)))
|
||||
(loop (cdr l) (append next-res res) origin
|
||||
current-rr-name ttl))
|
||||
(else
|
||||
(loop (cdr l) (cons next-res res) origin
|
||||
current-rr-name ttl)))))))
|
||||
|
||||
|
||||
;; Stuff for the main parser algorithm:
|
||||
;; ------------------------------------
|
||||
|
||||
;; Searches the results of parse-mf-line for a message-class
|
||||
(define (get-message-class rrlist)
|
||||
(let loop ((res rrlist))
|
||||
(if (null? res)
|
||||
#f
|
||||
(let ((class (caddr (car res))))
|
||||
(if class class
|
||||
(loop (cdr res)))))))
|
||||
|
||||
;; Set the results of parse-mf-line to a message-class...
|
||||
(define (set-message-class rrlist class)
|
||||
(map (lambda (e)
|
||||
(cons (car e) (cons (cadr e) (cons class (cdddr e)))))
|
||||
rrlist))
|
||||
|
||||
;; Searches the results of parse-mf-line for the shortest ttl
|
||||
(define (get-soa-ttl rrlist)
|
||||
(let loop ((l rrlist))
|
||||
(if (null? l)
|
||||
#f
|
||||
(let* ((rrs (car l))
|
||||
(rr-type (cadddr rrs)))
|
||||
(if (eq? (message-type soa) rr-type)
|
||||
(let* ((rdata (cadddr (cdr rrs))))
|
||||
(parse-mf-time-value? (list-ref rdata 6)))
|
||||
(loop (cdr l)))))))
|
||||
|
||||
;; Set the ttl of lines without one...
|
||||
(define (set-ttl rrlist soa-ttl)
|
||||
(map (lambda (e)
|
||||
(let ((ttl (cadr e)))
|
||||
(if (and ttl
|
||||
(< soa-ttl ttl))
|
||||
e
|
||||
(cons (car e) (cons soa-ttl (cddr e))))))
|
||||
rrlist))
|
||||
|
||||
|
||||
;; The main parser algorithm:
|
||||
;; --------------------------
|
||||
|
||||
;; Create a list of lexems and parse the lexems into resource-record-data:
|
||||
;; TYPE: string x dnsd-options -> list-of-resourec-records
|
||||
(define (parse-mf file dnsd-options)
|
||||
(and-let* ((lex-list (lex-masterfile file dnsd-options))
|
||||
(lines (parse-mf-lex->lines lex-list))
|
||||
(res (parse-mf-lexem-list lines "." "" #f dnsd-options))
|
||||
(class (get-message-class res))
|
||||
(res (set-message-class res class))
|
||||
(soa-ttl (get-soa-ttl res))
|
||||
(res (set-ttl res soa-ttl))
|
||||
(res (map (lambda (e) (parse-mf-create-rr e)) res)))
|
||||
;; Check if there is a line with an error:
|
||||
(fold-right (lambda (e l) (if (and e l) (cons e l) #f)) '() res)))
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
; --------------------
|
||||
; --- masterfile.l ---
|
||||
; --------------------
|
||||
|
||||
; A SIlex configuration file for masterfiles.
|
||||
; For more information about SILex visit: http://www.iro.umontreal.ca/~dube/
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
dchars [^\n();@ ] ;; last two chars are space and tabulator
|
||||
space [ ] ;; space and tabulator
|
||||
|
||||
%%
|
||||
|
||||
{space} (yycontinue)
|
||||
\n 'newline
|
||||
\n{space} 'blank-newline
|
||||
\; (let loop ((c (yygetc)))
|
||||
(cond
|
||||
((eq? 'eof c) 'eof)
|
||||
((char=? #\newline c)
|
||||
(begin
|
||||
(yyungetc)
|
||||
(yycontinue)))
|
||||
(else (loop (yygetc)))))
|
||||
\( 'left-par
|
||||
\) 'right-par
|
||||
(\$)ORIGIN 'origin
|
||||
(\$)INCLUDE 'include
|
||||
(\$)GENERATE 'generate
|
||||
(\$)TTL 'ttl
|
||||
\@ 'origin-ref
|
||||
{dchars}* yytext
|
||||
|
||||
<<EOF>> 'eof
|
||||
<<ERROR>> (error (yygetc))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,214 +0,0 @@
|
|||
; ---------------------
|
||||
; --- DNSD-Options ---
|
||||
; ---------------------
|
||||
|
||||
; Options for DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; The format and style of the option procedures is the same as seen
|
||||
; in the SUNet HTTPD & FTPD - Files
|
||||
|
||||
(define-record-type dnsd-options :dnsd-options
|
||||
(really-make-dnsd-options
|
||||
port dir nameservers use-axfr use-cache cleanup-interval retry-interval
|
||||
use-db use-recursion rec-timeout socket-timeout socket-max-tries
|
||||
max-connections blacklist-time blacklist-value use-pre/post debug-mode)
|
||||
dnsd-options?
|
||||
(port dnsd-options-port set-dnsd-options-port!)
|
||||
(dir dnsd-options-dir set-dnsd-options-dir!)
|
||||
(nameservers dnsd-options-nameservers set-dnsd-options-nameservers!)
|
||||
(use-axfr dnsd-options-use-axfr? set-dnsd-options-use-axfr?!)
|
||||
(use-cache dnsd-options-use-cache? set-dnsd-options-use-cache?!)
|
||||
(cleanup-interval dnsd-options-cleanup-interval set-dnsd-options-cleanup-interval!)
|
||||
(retry-interval dnsd-options-retry-interval set-dnsd-options-retry-interval!)
|
||||
(use-db dnsd-options-use-db? set-dnsd-options-use-db?!)
|
||||
(use-recursion dnsd-options-use-recursion? set-dnsd-options-use-recursion?!)
|
||||
(rec-timeout dnsd-options-rec-timeout set-dnsd-options-rec-timeout!)
|
||||
(socket-timeout dnsd-options-socket-timeout set-dnsd-options-socket-timeout!)
|
||||
(socket-max-tries dnsd-options-socket-max-tries set-dnsd-options-socket-max-tries!)
|
||||
(max-connections dnsd-options-max-connections set-dnsd-options-max-connections!)
|
||||
(blacklist-time dnsd-options-blacklist-time set-dnsd-options-blacklist-time!)
|
||||
(blacklist-value dnsd-options-blacklist-value set-dnsd-options-blacklist-value!)
|
||||
(use-pre/post dnsd-options-use-pre/post set-dnsd-options-use-pre/post!)
|
||||
(debug-mode dnsd-options-debug-mode set-dnsd-options-debug-mode!))
|
||||
|
||||
|
||||
(define (make-default-dnsd-options)
|
||||
(really-make-dnsd-options
|
||||
53 ; Port to listen
|
||||
"./" ; Path to the zone & option files.
|
||||
'() ; Use the default SBELT-Servers
|
||||
; Example-list: (list "192.168.2.1" "193.159.170.187" "192.36.148.17")
|
||||
; or (dns-find-nameserver-list) ; SBELT-Nameserver(s) for recursion.
|
||||
#t ; Toggles sending AXFR-responses
|
||||
#t ; Toggles the use of the cache
|
||||
(* 60 60) ; Cache garbage-collect interval in seconds
|
||||
(* 60 60) ; Min. time-val (sec) to reload a zone
|
||||
#t ; If #f don't use the db.
|
||||
#t ; If #f don't use recursion.
|
||||
10 ; Timeout (sec) for recursion.
|
||||
2 ; Timeout (sec) for a query (resolver interface).
|
||||
3 ; Max. tries on a socket (resolver interface).
|
||||
25 ; Max. concurrent connections for UDP and TCP.
|
||||
(* 60 30) ; How long will a blacklist entry be valid?
|
||||
5 ; How often must a NS be bad to be ignored.
|
||||
#f ; Don't use pre- and post-processing by default.
|
||||
#f)) ; Print debug-options to syslog.
|
||||
|
||||
(define (copy-dnsd-options options)
|
||||
(really-make-dnsd-options (dnsd-options-port options)
|
||||
(dnsd-options-dir options)
|
||||
(dnsd-options-nameservers options)
|
||||
(dnsd-options-use-axfr? options)
|
||||
(dnsd-options-use-cache? options)
|
||||
(dnsd-options-cleanup-interval options)
|
||||
(dnsd-options-retry-interval options)
|
||||
(dnsd-options-use-db? options)
|
||||
(dnsd-options-use-recursion? options)
|
||||
(dnsd-options-rec-timeout options)
|
||||
(dnsd-options-socket-timeout options)
|
||||
(dnsd-options-socket-max-tries options)
|
||||
(dnsd-options-max-connections options)
|
||||
(dnsd-options-blacklist-time options)
|
||||
(dnsd-options-blacklist-value options)
|
||||
(dnsd-options-use-pre/post options)
|
||||
(dnsd-options-debug-mode options)))
|
||||
|
||||
(define (make-dnsd-options-transformer set-option!)
|
||||
(lambda (new-value . stuff)
|
||||
(let ((new-options (if (not (null? stuff))
|
||||
(copy-dnsd-options (car stuff))
|
||||
(make-default-dnsd-options))))
|
||||
(set-option! new-options new-value)
|
||||
new-options)))
|
||||
|
||||
|
||||
(define with-port
|
||||
(make-dnsd-options-transformer set-dnsd-options-port!))
|
||||
(define with-dir
|
||||
(make-dnsd-options-transformer set-dnsd-options-dir!))
|
||||
(define with-nameservers
|
||||
(make-dnsd-options-transformer set-dnsd-options-nameservers!))
|
||||
(define with-axfr
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-axfr?!))
|
||||
(define with-cache
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-cache?!))
|
||||
(define with-cleanup-interval
|
||||
(make-dnsd-options-transformer set-dnsd-options-cleanup-interval!))
|
||||
(define with-retry-interval
|
||||
(make-dnsd-options-transformer set-dnsd-options-retry-interval!))
|
||||
(define with-db
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-db?!))
|
||||
(define with-recursion
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-recursion?!))
|
||||
(define with-rec-timeout
|
||||
(make-dnsd-options-transformer set-dnsd-options-rec-timeout!))
|
||||
(define with-socket-timeout
|
||||
(make-dnsd-options-transformer set-dnsd-options-socket-timeout!))
|
||||
(define with-socket-max-tries
|
||||
(make-dnsd-options-transformer set-dnsd-options-socket-max-tries!))
|
||||
(define with-max-connections
|
||||
(make-dnsd-options-transformer set-dnsd-options-max-connections!))
|
||||
(define with-blacklist-time
|
||||
(make-dnsd-options-transformer set-dnsd-options-blacklist-time!))
|
||||
(define with-blacklist-value
|
||||
(make-dnsd-options-transformer set-dnsd-options-blacklist-value!))
|
||||
(define with-use-pre/post
|
||||
(make-dnsd-options-transformer set-dnsd-options-use-pre/post!))
|
||||
(define with-debug-mode
|
||||
(make-dnsd-options-transformer set-dnsd-options-debug-mode!))
|
||||
|
||||
(define (make-dnsd-options . stuff)
|
||||
(let loop ((options (make-default-dnsd-options))
|
||||
(stuff stuff))
|
||||
(if (null? stuff)
|
||||
options
|
||||
(let* ((transformer (car stuff))
|
||||
(value (cadr stuff)))
|
||||
(loop (transformer value options)
|
||||
(cddr stuff))))))
|
||||
|
||||
(define (make-options-from-list o-list options)
|
||||
(if (eq? (car o-list) 'options)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (e)
|
||||
(let ((id (car e))
|
||||
(value (cadr e)))
|
||||
(case id
|
||||
((dir)
|
||||
(if (string? value)
|
||||
(set-dnsd-options-dir! options value)
|
||||
(error "Bad option argument.")))
|
||||
((nameservers)
|
||||
(if (list? value)
|
||||
(set-dnsd-options-nameservers! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-axfr)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-axfr?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-cache)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-cache?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((cleanup-interval)
|
||||
(if (and (number? value) (<= 10 value))
|
||||
(set-dnsd-options-cleanup-interval! options value)
|
||||
(error "Bad option argument.")))
|
||||
((retry-interval)
|
||||
(if (and (number? value) (<= 10 value))
|
||||
(set-dnsd-options-retry-interval! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-db)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-db?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((use-recursion)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-recursion?! options value)
|
||||
(error "Bad option argument.")))
|
||||
((rec-timeout)
|
||||
(if (and (number? value) (<= 1 value))
|
||||
(set-dnsd-options-rec-timeout! options value)
|
||||
(error "Bad options argument.")))
|
||||
((socket-timeout)
|
||||
(if (and (number? value) (<= 1 value) (> 13 value))
|
||||
(set-dnsd-options-socket-timeout! options value)
|
||||
(error "Bad options argument.")))
|
||||
((socket-max-tries)
|
||||
(if (and (number? value) (<= 1 value) (> 13 value))
|
||||
(set-dnsd-options-socket-max-tries! options value)
|
||||
(error "Bad options argument.")))
|
||||
((max-connections)
|
||||
(if (and (number? value) (<= 1 value))
|
||||
(set-dnsd-options-max-connections! options value)
|
||||
(error "Bad options argument.")))
|
||||
((blacklist-time)
|
||||
(if (and (number? value) (<= 60 value))
|
||||
(set-dnsd-options-blacklist-time! options value)
|
||||
(error "Bad options argument.")))
|
||||
((blacklist-value)
|
||||
(if (and (number? value) (<= 1 value))
|
||||
(set-dnsd-options-blacklist-value! options value)
|
||||
(error "Bad options argument.")))
|
||||
((use-pre/post)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-use-pre/post! options value)
|
||||
(error "Bad options argument.")))
|
||||
((debug-mode)
|
||||
(if (boolean? value)
|
||||
(set-dnsd-options-debug-mode! options value)
|
||||
(error "Bad options argument.")))
|
||||
(else (error "Bad option.")))))
|
||||
(cdr o-list))
|
||||
options)
|
||||
(error "Not an option list.")))
|
||||
|
||||
|
||||
|
|
@ -1,753 +0,0 @@
|
|||
; ----------------
|
||||
; --- Resolver ---
|
||||
; ----------------
|
||||
|
||||
; A DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; Interface:
|
||||
; ----------
|
||||
|
||||
;(dnsd-ask-resolver-rec message protocol dnsd-options)
|
||||
|
||||
;(dnsd-ask-resolver-direct message list-of-nameservers protocol dnsd-options)
|
||||
|
||||
|
||||
;; The modified send-receive-message socket-interface from dns.scm:
|
||||
;; ----------------------------------------------------------------
|
||||
|
||||
;; Delete the given element(s) from the list:
|
||||
;; TYPE: list x list -> list
|
||||
(define (delete-list elems list)
|
||||
(cond
|
||||
((null? elems) list)
|
||||
((null? list) '())
|
||||
(else (delete-list (cdr elems) (delete (car elems) list)))))
|
||||
|
||||
|
||||
;; dnsd wants the message, not the dns-error codes.
|
||||
(define (dnsd-acceptable? reply query)
|
||||
(if (not (= (header-id (message-header reply))
|
||||
(header-id (message-header query))))
|
||||
(error "send-receive-message: Bad reply-ID from server.")))
|
||||
|
||||
|
||||
(define (dnsd-send-receive-message-tcp nameserver query dnsd-options)
|
||||
(send-receive-message-tcp-int nameserver query dnsd-acceptable? dnsd-options))
|
||||
|
||||
(define (send-receive-message-tcp-int nameservers query accept? dnsd-options)
|
||||
(receive
|
||||
(reply hit-ns other-nss)
|
||||
(let* ((sockets (map (lambda (nameserver)
|
||||
(let ((sock (create-socket protocol-family/internet
|
||||
socket-type/stream))
|
||||
(addr (internet-address->socket-address
|
||||
nameserver 53)))
|
||||
;; Ignore return value and select unconditionally later
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline) #f)
|
||||
(lambda ()
|
||||
(connect-socket-no-wait sock addr) sock))))
|
||||
nameservers))
|
||||
(nameservers (let loop ((sockets sockets)
|
||||
(nss nameservers))
|
||||
(cond
|
||||
((or (null? sockets) (null? nss)) '())
|
||||
((socket? (car sockets))
|
||||
(cons (car nss) (loop (cdr sockets) (cdr nss))))
|
||||
(else (loop (cdr sockets) (cdr nss))))))
|
||||
(sockets (filter socket? sockets))
|
||||
(ws (map socket:outport sockets))
|
||||
(wport-nameserver-alist (map cons ws nameservers))
|
||||
(wport-socket-alist (map cons ws sockets)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(for-each close-socket sockets)
|
||||
decline)
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () 'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(let loop-port-channels ((tried-channels '())
|
||||
(number-tries 1))
|
||||
;; No channels left to try?
|
||||
(if (or (null? (delete-list tried-channels ws))
|
||||
(= (length tried-channels) (length ws))
|
||||
(>= number-tries
|
||||
(dnsd-options-socket-max-tries dnsd-options)))
|
||||
(values query #f nameservers)
|
||||
(let ((ready
|
||||
(apply select-ports
|
||||
(dnsd-options-socket-timeout dnsd-options)
|
||||
ws)))
|
||||
(let loop-ready-channels ((ready-channels ready))
|
||||
(if (null? ready-channels)
|
||||
(loop-port-channels (append tried-channels ready)
|
||||
(+ number-tries 1))
|
||||
(let* ((w (car ready-channels))
|
||||
(hit-ns
|
||||
(cdr (assoc w wport-nameserver-alist)))
|
||||
(sock (cdr (assoc w wport-socket-alist))))
|
||||
(if (not (connect-socket-successful? sock))
|
||||
(loop-ready-channels (cdr ready-channels))
|
||||
(let ((query-string (list->string
|
||||
(add-size-tag
|
||||
(message-source query))))
|
||||
(r (socket:inport sock)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(loop-ready-channels (cdr ready-channels)))
|
||||
(lambda ()
|
||||
(display query-string w)
|
||||
(force-output w)
|
||||
(let ((a (read-char r))
|
||||
(b (read-char r)))
|
||||
(let ((len (octet-pair->number a b)))
|
||||
(let ((s (read-string len r)))
|
||||
(if (and (not (= 0 (string-length s)))
|
||||
(not (= len (string-length s))))
|
||||
(error 'unexpected-eof-from-server))
|
||||
(values (parse (string->list s)) hit-ns
|
||||
(delete hit-ns nameservers))))))))))))))))
|
||||
(lambda () (for-each close-socket sockets))))))
|
||||
(accept? reply query)
|
||||
(values reply hit-ns other-nss)))
|
||||
|
||||
|
||||
(define (dnsd-send-receive-message-udp nameserver query dnsd-options)
|
||||
(send-receive-message-udp-int nameserver query dnsd-acceptable? dnsd-options))
|
||||
|
||||
|
||||
(define (send-receive-message-udp-int nameservers query accept? dnsd-options)
|
||||
(receive
|
||||
(reply hit-ns other-nss)
|
||||
(let* ((sockets (map (lambda (nameserver)
|
||||
(let ((sock (create-socket protocol-family/internet
|
||||
socket-type/datagram))
|
||||
(addr (internet-address->socket-address
|
||||
nameserver 53)))
|
||||
(connect-socket sock addr)
|
||||
sock))
|
||||
nameservers))
|
||||
(rs (map socket:inport sockets))
|
||||
(ws (map socket:outport sockets)))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(for-each close-socket sockets)
|
||||
decline)
|
||||
(lambda ()
|
||||
(dynamic-wind
|
||||
(lambda () 'nothing-to-be-done-before)
|
||||
(lambda ()
|
||||
(let ((query-string (list->string (message-source query)))
|
||||
(rsv (list->vector rs))
|
||||
(rport-nameserver-alist (map cons rs nameservers))
|
||||
(rport-socket-alist (map cons rs sockets)))
|
||||
(for-each (lambda (w) (display query-string w)) ws)
|
||||
(for-each force-output ws)
|
||||
(let loop-port-channels ((tried-channels '())
|
||||
(number-tries 1))
|
||||
(let ((rs-new (delete-list tried-channels rs)))
|
||||
(if (or (null? rs-new)
|
||||
(>= number-tries (dnsd-options-socket-max-tries dnsd-options))
|
||||
(= (length tried-channels) (length rs)))
|
||||
(values query #f nameservers)
|
||||
(let ((ready (apply select-ports
|
||||
(dnsd-options-socket-timeout dnsd-options)
|
||||
rs-new)))
|
||||
(let loop-ready-channels ((ready-channels ready))
|
||||
(if (null? ready-channels)
|
||||
(loop-port-channels (append tried-channels ready)
|
||||
(+ number-tries 1))
|
||||
(let* ((r (car ready-channels))
|
||||
(hit-ns (cdr (assoc r rport-nameserver-alist))))
|
||||
(if (not (connect-socket-successful?
|
||||
(cdr (assoc r rport-socket-alist))))
|
||||
(loop-ready-channels (cdr ready-channels))
|
||||
;; 512 is the maximum udp-message size:
|
||||
(let ((answer (string->list (read-string/partial 512 r))))
|
||||
(if (null? answer)
|
||||
(loop-ready-channels (cdr ready-channels))
|
||||
(values (parse answer) hit-ns
|
||||
(delete hit-ns nameservers))))))))))))))
|
||||
(lambda () (for-each close-socket sockets))))))
|
||||
(accept? reply query)
|
||||
(if (flags-truncated? (header-flags (message-header reply)))
|
||||
(send-receive-message-tcp-int nameservers query accept?)
|
||||
(values reply hit-ns other-nss))))
|
||||
|
||||
|
||||
(define (dnsd-send-receive-message nameservers query protocol dnsd-options)
|
||||
((cond
|
||||
((eq? protocol (network-protocol tcp)) dnsd-send-receive-message-tcp)
|
||||
((eq? protocol (network-protocol udp)) dnsd-send-receive-message-udp))
|
||||
nameservers query dnsd-options))
|
||||
|
||||
|
||||
;; Stuff:
|
||||
;; ------
|
||||
|
||||
; Filter a list of rrs of the given type:
|
||||
; TYPE: list-of-rrs -> list-of-rrs
|
||||
(define (filter-rr-type type list)
|
||||
(filter (lambda (e) (eq? (resource-record-type e) type)) list))
|
||||
|
||||
|
||||
;; Randomize a list (needs srfi-1 & srfi-27):
|
||||
;; TYPE: list -> list
|
||||
(define (shake-list l)
|
||||
(define (shake-list-int l res)
|
||||
(if (null? l)
|
||||
res
|
||||
(let ((random-value (random-integer (length l))))
|
||||
(shake-list-int
|
||||
(append (take l random-value) (drop l (+ 1 random-value)))
|
||||
(cons (list-ref l random-value) res)))))
|
||||
(shake-list-int l '()))
|
||||
|
||||
|
||||
|
||||
;; Check a message for its response-code:
|
||||
;; --------------------------------------
|
||||
|
||||
;; RCODE-0-Message? (Error-Free)
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-0-reply? msg)
|
||||
(eq? 'dns-no-error (flags-response-code (header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; RCODE-3-Message? (Name-Error (does not exist))
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-3-reply? msg)
|
||||
(eq? 'dns-name-error (flags-response-code
|
||||
(header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; RCODE-2-Message? Server-Failure
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-2-reply? msg)
|
||||
(eq? 'dns-server-failure (flags-response-code
|
||||
(header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; RCODE-4-Message? Not Implemented
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-4-reply? msg)
|
||||
(eq? 'dns-not-implemented (flags-response-code
|
||||
(header-flags (message-header msg)))))
|
||||
|
||||
;; RCODE-5-Message? (Refused to answer query.)
|
||||
;; TYPE: message -> boolean
|
||||
(define (rcode-5-reply? msg)
|
||||
(eq? 'dns-refused (flags-response-code (header-flags (message-header msg)))))
|
||||
|
||||
|
||||
;; Are there just CNAMEs in the answer-section of a reply?
|
||||
;; TYPE message -> boolean
|
||||
(define (cname-answer? msg)
|
||||
(let ((cnames (fold-right
|
||||
(lambda (e b)
|
||||
(or (eq? (message-type cname) (resource-record-type e)) b))
|
||||
#f (message-answers msg)))
|
||||
(other (fold-right
|
||||
(lambda (e b)
|
||||
(or (not (eq? (message-type cname)
|
||||
(resource-record-type e))) b))
|
||||
#f (message-answers msg))))
|
||||
(if other #f cnames)))
|
||||
|
||||
|
||||
;; Interpreting the results of dbi-lookup-rec - Zone found, but not the name.
|
||||
;; TYPE res-list-of-db-lookup-rec -> boolean
|
||||
(define (no-entry? res-l)
|
||||
(and (null? (car res-l)) (null? (cadr res-l))
|
||||
(null? (caddr res-l)) (cadddr res-l)))
|
||||
|
||||
|
||||
;; Is the query a cname-question?
|
||||
;; TYPE: message -> boolean
|
||||
(define (cname-question? msg)
|
||||
(eq? (message-type cname) (question-type (car (message-questions msg)))))
|
||||
|
||||
|
||||
;; Create a reply from the internally found (db or cache) information.
|
||||
;; NOTE: This function is part of the exported functions.
|
||||
;; TYPE: message x res-list-of-db-lookup-rec x dnsd-options -> message
|
||||
(define (make-response message r-list dnsd-options)
|
||||
(let* ((use-recursion? (dnsd-options-use-recursion? dnsd-options))
|
||||
(error-code (if (no-entry? r-list) 'dns-name-error 'dns-no-error))
|
||||
(msg-header (message-header message))
|
||||
(msg-flags (header-flags msg-header))
|
||||
(anli (car r-list))
|
||||
(auli (cadr r-list))
|
||||
(adli (caddr r-list))
|
||||
(aufl (cadddr r-list)))
|
||||
(make-message
|
||||
(make-header (header-id msg-header)
|
||||
(make-flags
|
||||
'response
|
||||
(flags-opcode msg-flags)
|
||||
aufl
|
||||
(flags-truncated? msg-flags)
|
||||
(flags-recursion-desired? msg-flags)
|
||||
use-recursion?
|
||||
(flags-zero msg-flags)
|
||||
error-code)
|
||||
(header-question-count msg-header)
|
||||
(length anli)
|
||||
(length auli)
|
||||
(length adli))
|
||||
(message-questions message)
|
||||
anli auli adli '())))
|
||||
|
||||
|
||||
;; Increment the answer-section (for adding a cname)
|
||||
;; TYPE: message -> message
|
||||
(define (msg-inc-answers msg-header)
|
||||
(let ((msg-flags (header-flags msg-header)))
|
||||
(make-header (header-id msg-header)
|
||||
msg-flags
|
||||
(header-question-count msg-header)
|
||||
(+ 1 (header-answer-count msg-header))
|
||||
(header-nameserver-count msg-header)
|
||||
(header-additional-count msg-header))))
|
||||
|
||||
|
||||
;; Change the type of a question to (message-type cname)
|
||||
;; TYPE: messag -> message
|
||||
(define (msg->cname-msg msg)
|
||||
(let ((q (car (message-questions msg))))
|
||||
(make-message (message-header msg)
|
||||
(list (make-question (question-name q)
|
||||
(message-type cname)
|
||||
(question-class q)))
|
||||
(message-answers msg)
|
||||
(message-nameservers msg)
|
||||
(message-additionals msg) '())))
|
||||
|
||||
|
||||
;; Assignment procs:
|
||||
;; -----------------
|
||||
|
||||
;; Set the recursion-aviable flag:
|
||||
;; TYPE: message x boolean -> message
|
||||
(define (msg-set-recursion-aviable! msg bool)
|
||||
(set-flags-recursion-available! (header-flags (message-header msg)) bool))
|
||||
|
||||
|
||||
;; Set the response-code of a message:
|
||||
;; NOTE: This function is part of the exported functions.
|
||||
;; TYPE: message x rcode -> message
|
||||
(define (msg-set-rcode! msg code)
|
||||
(let ((rcode (case code
|
||||
((0) 'dns-no-error)
|
||||
((1) 'dns-format-error)
|
||||
((2) 'dns-server-failure)
|
||||
((3) 'dns-name-error)
|
||||
((4) 'dns-not-implemented)
|
||||
((5) 'dns-refused)
|
||||
(else code))))
|
||||
(set-flags-response-code! (header-flags (message-header msg)) rcode)))
|
||||
|
||||
|
||||
;; Direct lookup:
|
||||
;; --------------
|
||||
|
||||
;; Direct lookup of a query asking the given Nameserves:
|
||||
;; TYPE: message x list-of-address32 tcp/udp x dnsd-options -> message
|
||||
(define (dnsd-lookup-direct msg ns-list proto dnsd-options)
|
||||
(receive (msg hit-ip other-ips)
|
||||
(dnsd-send-receive-message
|
||||
ns-list
|
||||
(make-message (message-header msg) (message-questions msg)
|
||||
(message-answers msg) (message-nameservers msg)
|
||||
(message-additionals msg) (mc-message->octets msg))
|
||||
proto dnsd-options)
|
||||
(if hit-ip
|
||||
msg
|
||||
(begin
|
||||
(dnsd-log (syslog-level info)
|
||||
"dnsd-direct-lookup. Nameservers ~S not reachable."
|
||||
ns-list)
|
||||
(error "dnsd-direct-lookup. No NS reachable.")))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; Stuff for recursive lookup:
|
||||
;; ---------------------------
|
||||
|
||||
|
||||
;; SBELT:
|
||||
;; ------
|
||||
|
||||
;; Fallback nameserver for recursive lookup. This is the default value which
|
||||
;; can be changed by the dnsd-options:
|
||||
(define *sbelt*
|
||||
(list ;(ip-string->address32 "192.5.5.241")
|
||||
(ip-string->address32 "192.36.148.17")
|
||||
(ip-string->address32 "192.5.5.241")))
|
||||
|
||||
|
||||
;; Some nameserver IPs:
|
||||
;; --------------------
|
||||
|
||||
;; 192.36.148.17 i.root-servers.net. (for .)
|
||||
;; 192.5.5.241 f.root-server.net. (for .)
|
||||
|
||||
;; 192.5.6.30 A.GTLD-SERVERS.NET. (for .com.
|
||||
;; 193.159.170.187 deNIC-NS (for .de.)
|
||||
|
||||
|
||||
;; Record-Type for additional information needed by the lookup:
|
||||
;; cnames is a list of all seen CNAMES to avoid CNAME-loops.
|
||||
;; ips is a list of used NS-IPs for the query.
|
||||
;; timestamp is the creation-time of the context and used for timeouts.
|
||||
(define-record-type context :context
|
||||
(really-make-context cnames ips timestamp)
|
||||
context?
|
||||
(cnames get-context-cnames set-context-cnames!)
|
||||
(ips get-context-ips set-context-ips!)
|
||||
(timestamp get-context-timestamp))
|
||||
|
||||
|
||||
;; Makes the lookup-context for a given query.
|
||||
;; TYPE: message -> context
|
||||
(define (make-context message)
|
||||
(really-make-context
|
||||
(list (question-name (car (message-questions message))))
|
||||
'()
|
||||
(time)))
|
||||
|
||||
;; Add a name to the context.
|
||||
;; TYPE: context x string -> context
|
||||
(define (update-context-cnames! context value)
|
||||
(set-context-cnames! context (cons value (get-context-cnames context)))
|
||||
context)
|
||||
|
||||
;; Add a IP to the context.
|
||||
;; TYPE: context x address32 -> context
|
||||
(define (update-context-ips! context value)
|
||||
(set-context-ips! context (cons value (get-context-ips context)))
|
||||
context)
|
||||
|
||||
|
||||
;; Search the SLIST for the best 'nearest' nameserver to query for a message.
|
||||
;; The nearest server is the server for the domain with the most matching labels
|
||||
;; seen from the root: 1) www.example.com. 2) example.com. 3) com. 4) . 5) SBELT
|
||||
;; TYPE: message x dnsd-options -> list-of-nameserver-ips x zone-name-of-ns
|
||||
(define (search-for-ns-ips msg dnsd-options)
|
||||
(let* ((q (car (message-questions msg)))
|
||||
(name (question-name q))
|
||||
(class (question-class q)))
|
||||
(let loop ((name name))
|
||||
(let ((ip-list (dnsd-slist-lookup
|
||||
(make-simple-query-message name (message-type ns) class)
|
||||
dnsd-options)))
|
||||
(if ip-list
|
||||
(values ip-list name #f)
|
||||
(if (string=? "." name)
|
||||
(let* ((sbelt-string (dnsd-options-nameservers dnsd-options))
|
||||
(sbelt (map ip-string->address32 sbelt-string)))
|
||||
(if (null? sbelt)
|
||||
(values *sbelt* name #t)
|
||||
(values sbelt name #t)))
|
||||
(loop (cut-name name))))))))
|
||||
|
||||
|
||||
;; Ask the message to some NS from the SLIST. Keep track which NSs were already
|
||||
;; contacted for the given query in 'context'.
|
||||
;; TYPE: message x udp/tcp x dnsd-options x context
|
||||
;; -> message-answer x context x nearest-NS-string x address32
|
||||
(define (ask-nameservers msg protocol dnsd-options context)
|
||||
(receive
|
||||
(ip-list name sbelt?)
|
||||
(search-for-ns-ips msg dnsd-options)
|
||||
;; Use only IPs which haven't been tried jet
|
||||
(let ((good-ips (filter (lambda (e)
|
||||
(not (fold-right
|
||||
(lambda (e1 b)
|
||||
(or b (= e1 e)))
|
||||
#f (get-context-ips context))))
|
||||
ip-list)))
|
||||
;; randomize the list for some simple load-balancing...
|
||||
(let loop ((good-ips (shake-list good-ips)))
|
||||
(if (null? good-ips)
|
||||
(error "ask-nameservers: Tried all known Nameservers.")
|
||||
(receive
|
||||
(msg hit-ip other-ips)
|
||||
(dnsd-send-receive-message
|
||||
(list (car good-ips))
|
||||
(make-message (message-header msg) (message-questions msg)
|
||||
(message-answers msg) (message-nameservers msg)
|
||||
(message-additionals msg) (mc-message->octets msg))
|
||||
protocol dnsd-options)
|
||||
(if hit-ip
|
||||
(values msg (update-context-ips! context hit-ip)
|
||||
name hit-ip)
|
||||
(begin
|
||||
(if (not sbelt?) (dnsd-blacklist! (car good-ips)))
|
||||
(loop (cdr good-ips))))))))))
|
||||
|
||||
|
||||
|
||||
;; Some responses contain nameserver-names but sadly not their IPs.
|
||||
;; This function searches for those IPs, add the results to the
|
||||
;; cache and restarts the recursive lookup.
|
||||
;; TYPE: message x udp/tcp x list-of-rrs x dnsd-options -> unspecific
|
||||
(define (lookup-nameserver-ips msg protocol ns-rrs dnsd-options)
|
||||
(let* ((ns-names (map (lambda (e) (resource-record-data-ns-name
|
||||
(resource-record-data e))) ns-rrs))
|
||||
(ns-queries (map (lambda (e)
|
||||
;;(display-debug "Looking for this names: " e)
|
||||
(make-simple-query-message
|
||||
e (message-type a)
|
||||
(question-class
|
||||
(car (message-questions msg))))) ns-names))
|
||||
; ;; This step might take a while :-(
|
||||
; (answers (map (lambda (e)
|
||||
; (dnsd-ask-resolver-rec e protocol dnsd-options))
|
||||
; ns-queries))
|
||||
;; Concurrent lookup of the IPs:
|
||||
(ch-list (map
|
||||
(lambda (msg)
|
||||
(let ((ch-res (make-channel)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(sync (send-rv
|
||||
ch-res
|
||||
;; Use dnsd-ask-r... because of the 'good'
|
||||
;; return value.
|
||||
(dnsd-ask-resolver-rec msg protocol
|
||||
dnsd-options)))))
|
||||
ch-res))
|
||||
ns-queries))
|
||||
;; Wait for all results:
|
||||
(answers (map (lambda (ch) (sync (receive-rv ch))) ch-list))
|
||||
(good-answers (filter (lambda (e) (rcode-0-reply? e)) answers))
|
||||
(ip-rrs (map (lambda (msg) (filter-rr-type (message-type a)
|
||||
(message-answers msg)))
|
||||
good-answers))
|
||||
(flat-ns-list (fold-right (lambda (e l) (append e l)) '() ip-rrs)))
|
||||
(if (null? flat-ns-list)
|
||||
#f ;TODO: Do we need a strategy to avoid loops if we don't find NS?
|
||||
(dnsd-slist-update!
|
||||
(make-message (message-header msg) (message-questions msg)
|
||||
'() ns-rrs flat-ns-list '())))))
|
||||
|
||||
|
||||
;; Restart dnsd-get-info-int with question-name changed to the cname.
|
||||
;; TYPE: query-message x response-message x udp/tcp x dnsd-options x context
|
||||
;; -> respones-message
|
||||
(define (cname-lookup msg res protocol dnsd-options context)
|
||||
(let* ((q (car (message-questions msg)))
|
||||
(msg-name (question-name q))
|
||||
(cname-rr (fold-right
|
||||
(lambda (e a)
|
||||
(if a a
|
||||
(if (and (eq? (message-type cname)
|
||||
(resource-record-type e))
|
||||
(string-ci=? (resource-record-name e)
|
||||
msg-name))
|
||||
e a)))
|
||||
#f (message-answers res)))
|
||||
(cname (resource-record-data-cname-name
|
||||
(resource-record-data cname-rr)))
|
||||
(found-loop? (fold-right (lambda (e b)
|
||||
(or (string-ci=? cname e) b))
|
||||
#f (get-context-cnames context))))
|
||||
(if found-loop? ; Check for CNAME-Loop
|
||||
(begin ;;(display-debug "Found a CNAME-loop. Aborting!")
|
||||
(error "Found a CNAME-loop. Aborting recursive lookup."))
|
||||
(let* ((new-msg (make-message (message-header msg)
|
||||
(list (make-question cname
|
||||
(question-type q)
|
||||
(question-class q)))
|
||||
'() '() '() '()))
|
||||
(res (dnsd-get-info-int new-msg protocol dnsd-options
|
||||
;; Keep timout, allow all IPs again...
|
||||
(really-make-context
|
||||
(cons cname (get-context-cnames context))
|
||||
'()
|
||||
(get-context-timestamp context))))
|
||||
(new-res (make-message (msg-inc-answers (message-header res))
|
||||
(message-questions msg)
|
||||
(cons cname-rr (message-answers res))
|
||||
(message-nameservers res)
|
||||
(message-additionals res) '())))
|
||||
new-res))))
|
||||
|
||||
|
||||
|
||||
;; Recursive Lookup as seen in RFC 1034:
|
||||
;; -------------------------------------
|
||||
|
||||
;; 1) Check local information and (if present) return it to the client.
|
||||
;; 2) Search for server(s) to ask. Wait for a response.
|
||||
;; 3) Analyze the response:
|
||||
;; 3.1 cache answers or name error.
|
||||
;; 3.2 cache delegation info to other servers. Retry.
|
||||
;; 3.3 if the response shows a CNAME and that is not the
|
||||
;; answer itself, cache the CNAME, change the SNAME to the
|
||||
;; canonical name in the CNAME RR and go to step 1.
|
||||
;; 3.4 servers failure etc.: delete server from cache. Retry.
|
||||
|
||||
|
||||
;; Start the recursive lookup and initialize the first context-list
|
||||
;; with the name of the question (to avoid CNAME-Loops).
|
||||
;; TYPE: message x udp/tcp x dnsd-options -> message
|
||||
(define (dnsd-get-information message protocol dnsd-options)
|
||||
(dnsd-get-info-int message protocol dnsd-options (make-context message)))
|
||||
|
||||
|
||||
;; TYPE: message x udp/tcp x dnsd-options x context -> message
|
||||
(define (dnsd-get-info-int message protocol dnsd-options context)
|
||||
; 1) Search local information:
|
||||
(let* ((use-cache? (dnsd-options-use-cache? dnsd-options))
|
||||
(local-res (if use-cache? (dnsd-cache-lookup? message) #f)))
|
||||
;; Timeout?
|
||||
(if (> (- (time) (get-context-timestamp context))
|
||||
(dnsd-options-rec-timeout dnsd-options))
|
||||
(error "dnsd-get-info-int: Global timeout.")
|
||||
(if local-res (make-response message local-res dnsd-options)
|
||||
;; 2) Could be: Search for the best nameserver to ask.
|
||||
;; Now it's: Ask all servers concurrent and take
|
||||
;; the first result.
|
||||
(receive
|
||||
(rec-res context followed-name hit-ip)
|
||||
(ask-nameservers message protocol dnsd-options context)
|
||||
;; 3) Analyze the response:
|
||||
(let* ((ns-rrs (filter-rr-type (message-type ns)
|
||||
(message-nameservers rec-res)))
|
||||
(a-rrs (filter-rr-type (message-type a)
|
||||
(message-additionals rec-res))))
|
||||
(cond
|
||||
;; 3.4) Bad answer: Some NS are to 'lazy' to return cnames
|
||||
;; and return RCODE 5 instead. The NS of sourceforge.net.
|
||||
;; are a good bad example.
|
||||
((rcode-5-reply? rec-res)
|
||||
(if (not (cname-question? rec-res))
|
||||
(let ((cname-query
|
||||
(dnsd-get-information (msg->cname-msg message)
|
||||
protocol dnsd-options)))
|
||||
(if (cname-answer? cname-query)
|
||||
(cname-lookup message cname-query protocol
|
||||
dnsd-options context)
|
||||
(begin (dnsd-blacklist! hit-ip)
|
||||
rec-res)))
|
||||
(begin (dnsd-blacklist! hit-ip) rec-res)))
|
||||
;; 3.4) Try again with other servers.
|
||||
((rcode-2-reply? rec-res)
|
||||
(dnsd-blacklist! hit-ip)
|
||||
(dnsd-get-info-int message protocol dnsd-options context))
|
||||
((rcode-4-reply? rec-res)
|
||||
(dnsd-blacklist! hit-ip
|
||||
(dnsd-options-blacklist-value dnsd-options))
|
||||
(dnsd-get-info-int message protocol dnsd-options context))
|
||||
(else
|
||||
;; A "good" reply.
|
||||
(dnsd-blacklist-unlist! hit-ip dnsd-options)
|
||||
(cond
|
||||
;; 3.1) Found a name-error.
|
||||
((rcode-3-reply? rec-res)
|
||||
(dnsd-cache-update! rec-res) rec-res)
|
||||
;; 3.4) Whatever error is left... .
|
||||
((not (rcode-0-reply? rec-res)) rec-res)
|
||||
;; 3.1) Found an answer.
|
||||
((not (null? (message-answers rec-res)))
|
||||
;; 3.3) CNAME?
|
||||
(if (and (not (cname-question? rec-res))
|
||||
(cname-answer? rec-res))
|
||||
(begin
|
||||
(dnsd-cache-update! (msg->cname-msg rec-res))
|
||||
;;(display-debug "Starting CNAME Lookup!")
|
||||
(cname-lookup message rec-res protocol
|
||||
dnsd-options context))
|
||||
;; Returning of not-authoritative data
|
||||
;; may be a bad habbit...
|
||||
(if (flags-authoritative?
|
||||
(header-flags (message-header rec-res)))
|
||||
rec-res
|
||||
rec-res)))
|
||||
(else
|
||||
;; 3.2) Redirection to other Nameservers?
|
||||
(cond
|
||||
((null? ns-rrs) rec-res)
|
||||
((null? a-rrs)
|
||||
;; Only nameserver resource-records, search for IPs
|
||||
(lookup-nameserver-ips rec-res protocol
|
||||
ns-rrs dnsd-options)
|
||||
(dnsd-get-info-int message protocol dnsd-options context))
|
||||
(else
|
||||
(dnsd-slist-update! rec-res)
|
||||
(dnsd-get-info-int message protocol
|
||||
dnsd-options context)))))))))))))
|
||||
|
||||
|
||||
|
||||
;; ---------------------------------
|
||||
;; --- Server/Resolver-Interface ---
|
||||
;; ---------------------------------
|
||||
|
||||
;; (dnsd-ask-resolver-direct msg nameserver-list protocol dnsd-options)
|
||||
;; - Ask a specific nameserver (& don't use the SLIST-Interface.)
|
||||
;; (E.g. for the AXFR-Update algorihms.)
|
||||
;;
|
||||
;; (dnsd-ask-resolver-rec msg protocol dnsd-options)
|
||||
;; - Ask indirect (and recursive) via the SLIST-Cache.
|
||||
|
||||
|
||||
;; TYPE: message x upd/tcp x dnsd-options -> message
|
||||
(define (dnsd-ask-resolver-rec msg proto dnsd-options)
|
||||
(set-message-source! msg (mc-message->octets msg))
|
||||
(let ((ch-timeout (make-channel))
|
||||
(ch-res (make-channel)))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(sleep (* 1000 (dnsd-options-rec-timeout dnsd-options)))
|
||||
(sync (send-rv ch-timeout #t))))
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level debug)
|
||||
"Error during recursive lookup.")
|
||||
(msg-set-rcode! msg 2)
|
||||
msg)
|
||||
(lambda ()
|
||||
(sync (send-rv ch-res (dnsd-get-information msg
|
||||
proto dnsd-options)))))))
|
||||
(sync
|
||||
(choose
|
||||
(wrap (receive-rv ch-timeout)
|
||||
(lambda (ignore)
|
||||
(dnsd-log (syslog-level info)
|
||||
"Timeout during recursive lookup. Current value is ~Ds"
|
||||
(dnsd-options-rec-timeout dnsd-options))
|
||||
(msg-set-rcode! msg 2) msg))
|
||||
(wrap (receive-rv ch-res)
|
||||
(lambda (value)
|
||||
value))))))
|
||||
|
||||
|
||||
;; TYPE: message x list-of-address32 x upd/tcp x dnsd-options -> message
|
||||
(define (dnsd-ask-resolver-direct msg nameservers proto dnsd-options)
|
||||
(set-message-source! msg (mc-message->octets msg))
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(dnsd-log (syslog-level debug)
|
||||
"Error during direct lookup.")
|
||||
(msg-set-rcode! msg 2)
|
||||
msg)
|
||||
(lambda ()
|
||||
(dnsd-lookup-direct msg nameservers proto dnsd-options))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,177 +0,0 @@
|
|||
; ----------------------------------
|
||||
; --- Resource-Record-Definition ---
|
||||
; ----------------------------------
|
||||
|
||||
; Wrapper for (make-resource-record ___) from dns.scm:
|
||||
; * Abstraction of (make-resource-record ___ (make-resource-record-data-* ___))
|
||||
; * Now for all supported types: (dns-rr-<type> ...)
|
||||
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
|
||||
; Interface:
|
||||
|
||||
; (dns-rr-a ...)
|
||||
; (dns-rr-txt ...)
|
||||
; etc..
|
||||
|
||||
|
||||
|
||||
; Abstraction of (make-resource-record ... (make-resource-record-data-* ...))
|
||||
; Now: (dns-rr-* ...), trying to include data-integrity.
|
||||
|
||||
; *** Some stuff ***
|
||||
|
||||
(define (make-message-class class)
|
||||
(cond
|
||||
((number? class)
|
||||
(message-class-number->type class))
|
||||
((symbol? class)
|
||||
(message-class-symbol->type class))
|
||||
((message-class? class)
|
||||
class)
|
||||
(else #f)))
|
||||
|
||||
(define (make-message-type type)
|
||||
(cond
|
||||
((number? type)
|
||||
(message-type-number->type type))
|
||||
((symbol? type)
|
||||
(message-type-symbol->type type))
|
||||
((message-type? type)
|
||||
type)
|
||||
(else #f)))
|
||||
|
||||
(define (make-address32 ip)
|
||||
(cond
|
||||
((address32? ip) ip)
|
||||
((ip-string? ip)
|
||||
(ip-string->address32 ip))
|
||||
(else #f)))
|
||||
|
||||
|
||||
; Nice to know: valid ttls: 0-2147483647
|
||||
|
||||
; *02* - (dns-rr-* ...) functions:
|
||||
|
||||
; Warning: This functions won't work with any other class than 'IN'!
|
||||
|
||||
; TYPES: name x class x ttl x data -> resource-record-record-type or #f
|
||||
|
||||
(define (dns-rr-a name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(a32 (make-address32 data)))
|
||||
(make-resource-record
|
||||
name (message-type a)
|
||||
class ttl
|
||||
(make-resource-record-data-a a32))))
|
||||
|
||||
(define (dns-rr-ns name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(ns-name (make-fqdn-name data))
|
||||
(whatever (fqdn? ns-name)))
|
||||
(make-resource-record
|
||||
name (message-type ns)
|
||||
class ttl
|
||||
(make-resource-record-data-ns ns-name))))
|
||||
|
||||
(define (dns-rr-cname name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(cname-name (make-fqdn-name data))
|
||||
(whatever (fqdn? cname-name)))
|
||||
(make-resource-record
|
||||
name (message-type cname)
|
||||
class ttl
|
||||
(make-resource-record-data-cname cname-name))))
|
||||
|
||||
(define (dns-rr-soa name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(mname (make-fqdn-name (car data)))
|
||||
(whatever (fqdn? mname))
|
||||
(rname (make-fqdn-name (cadr data)))) ;! what's with fqdn...
|
||||
(make-resource-record
|
||||
name (message-type soa)
|
||||
class ttl
|
||||
(make-resource-record-data-soa
|
||||
mname rname
|
||||
(caddr data)
|
||||
(cadddr data)
|
||||
(cadr (cdddr data))
|
||||
(caddr (cdddr data))
|
||||
(cadddr (cdddr data))))))
|
||||
|
||||
(define (dns-rr-ptr name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(ptr-name (make-fqdn-name data))
|
||||
(whatever (fqdn? ptr-name)))
|
||||
(make-resource-record
|
||||
name (message-type ptr)
|
||||
class ttl
|
||||
(make-resource-record-data-ptr ptr-name))))
|
||||
|
||||
(define (dns-rr-hinfo name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in))))
|
||||
(make-resource-record
|
||||
name (message-type hinfo)
|
||||
class ttl
|
||||
(make-resource-record-data-hinfo data))))
|
||||
|
||||
(define (dns-rr-mx name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in)))
|
||||
(pref (car data))
|
||||
(whatever (number? pref))
|
||||
(mx-name (make-fqdn-name (cadr data)))
|
||||
(whatever (fqdn? mx-name)))
|
||||
(make-resource-record
|
||||
name (message-type mx)
|
||||
class ttl
|
||||
(make-resource-record-data-mx
|
||||
pref mx-name))))
|
||||
|
||||
(define (dns-rr-txt name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in))))
|
||||
(make-resource-record
|
||||
name (message-type txt)
|
||||
class ttl
|
||||
(make-resource-record-data-txt data))))
|
||||
|
||||
(define (dns-rr-aaaa name class ttl data)
|
||||
(and-let* ((name (make-fqdn-name name))
|
||||
(whatever (fqdn? name))
|
||||
(class (make-message-class class))
|
||||
(whatever (eq? class (message-class in))))
|
||||
(make-resource-record
|
||||
name (message-type aaaa)
|
||||
class ttl
|
||||
(make-resource-record-data-aaaa data))))
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
; -----------------------
|
||||
; --- Read/Write-Lock ---
|
||||
; -----------------------
|
||||
|
||||
; Locks for a DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
|
||||
; Simple locks for the dns-server database. The idea behind this sort of
|
||||
; lock is to permit multiple threads to read the data secured by the lock.
|
||||
; If a thread tries to write, it'll block all other access to the data
|
||||
; and do it's work isolated. (One write to block them all... ;-)
|
||||
|
||||
; Interface:
|
||||
|
||||
; (make-r/w-lock) : creates an r/w-lock
|
||||
|
||||
; (obtain-R/w-lock r/w-lock)
|
||||
; (obtain-r/W-lock r/w-lock)
|
||||
|
||||
; (release-R/w-lock r/w-lock)
|
||||
; (release-r/W-lock r/w-lock)
|
||||
|
||||
; (with-R/w-lock rwlock thunk)
|
||||
; (with-r/W-lock rwlock thunk)
|
||||
|
||||
|
||||
(define-record-type r/w-lock :r/w-lock
|
||||
(really-make-r/w-lock write-flag read-count write-lock mutex-lock)
|
||||
r/w-lock?
|
||||
(write-flag get-r/w-lock-write-flag set-r/w-lock-write-flag!)
|
||||
(read-count get-r/w-lock-read-count set-r/w-lock-read-count!)
|
||||
(write-lock get-r/w-lock-write-lock)
|
||||
(mutex-lock get-r/w-lock-mutex-lock))
|
||||
|
||||
(define (make-r/w-lock)
|
||||
(really-make-r/w-lock #f 0 (make-lock) (make-lock)))
|
||||
|
||||
(define (obtain-R/w-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
|
||||
(let loop ()
|
||||
(obtain-lock mutex-lock)
|
||||
; Is there is a thread writing?
|
||||
(if (get-r/w-lock-write-flag r/w-lock)
|
||||
(begin
|
||||
(release-lock mutex-lock)
|
||||
; Just wait for some time and try again...
|
||||
; TODO?: Do that with locks
|
||||
(relinquish-timeslice)
|
||||
(loop))
|
||||
(begin
|
||||
(set-r/w-lock-read-count!
|
||||
r/w-lock
|
||||
(+ 1 (get-r/w-lock-read-count r/w-lock)))
|
||||
(release-lock mutex-lock))))))
|
||||
|
||||
(define (release-R/w-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock)))
|
||||
(obtain-lock mutex-lock)
|
||||
(set-r/w-lock-read-count!
|
||||
r/w-lock (- (get-r/w-lock-read-count r/w-lock) 1))
|
||||
(release-lock mutex-lock)))
|
||||
|
||||
(define (obtain-r/W-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
|
||||
(write-lock (get-r/w-lock-write-lock r/w-lock)))
|
||||
; Maybe wait here for another write-thread:
|
||||
(obtain-lock write-lock)
|
||||
(let loop ()
|
||||
(obtain-lock mutex-lock)
|
||||
(set-r/w-lock-write-flag! r/w-lock #t)
|
||||
(if (= 0 (get-r/w-lock-read-count r/w-lock))
|
||||
(release-lock mutex-lock)
|
||||
(begin
|
||||
(release-lock mutex-lock)
|
||||
; Wait until the reads finish...
|
||||
; TODO?: Do that with locks
|
||||
(relinquish-timeslice)
|
||||
(loop))))))
|
||||
|
||||
(define (release-r/W-lock r/w-lock)
|
||||
(let ((mutex-lock (get-r/w-lock-mutex-lock r/w-lock))
|
||||
(write-lock (get-r/w-lock-write-lock r/w-lock)))
|
||||
(obtain-lock mutex-lock)
|
||||
(set-r/w-lock-write-flag! r/w-lock #f)
|
||||
(release-lock mutex-lock)
|
||||
(release-lock write-lock)))
|
||||
|
||||
(define (with-R/w-lock rwlock thunk)
|
||||
(obtain-R/w-lock rwlock)
|
||||
(let ((value (thunk)))
|
||||
(release-R/w-lock rwlock)
|
||||
value))
|
||||
|
||||
(define (with-r/W-lock rwlock thunk)
|
||||
(obtain-r/W-lock rwlock)
|
||||
(let ((value (thunk)))
|
||||
(release-r/W-lock rwlock)
|
||||
value))
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
; ----------------------
|
||||
; --- Semaphore-Lock ---
|
||||
; ----------------------
|
||||
|
||||
; Semaphore-locks for a DNS-Server based on the RFCs: 1034 / 1035
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; Wait on the semaphore-lock if the semaphore-counter reaches 0
|
||||
|
||||
; Interface:
|
||||
|
||||
; (make-semaphore initial-value)
|
||||
|
||||
; (set-semaphore! new-value)
|
||||
|
||||
; (semaphore-post semaphore)
|
||||
|
||||
; (semaphore-wait semaphore)
|
||||
|
||||
|
||||
(define-record-type semaphore :semaphore
|
||||
(really-make-semaphore value i waiting-list mutex-lock)
|
||||
semaphore?
|
||||
(value get-semaphore-value set-semaphore-value!)
|
||||
(i get-semaphore-counter set-semaphore-counter!)
|
||||
(waiting-list get-semaphore-waiting set-semaphore-waiting!)
|
||||
(mutex-lock get-semaphore-lock))
|
||||
|
||||
(define (make-semaphore i)
|
||||
(really-make-semaphore i i '() (make-lock)))
|
||||
|
||||
;; Reset the internal semaphore-counter.
|
||||
(define (set-semaphore! sem new-value)
|
||||
(if (semaphore? sem)
|
||||
(begin
|
||||
(obtain-lock (get-semaphore-lock sem))
|
||||
(let* ((old-value (get-semaphore-value sem))
|
||||
(diff (- new-value old-value)))
|
||||
(set-semaphore-value! sem new-value)
|
||||
(set-semaphore-counter! sem (+ (get-semaphore-counter sem) diff))
|
||||
(release-lock (get-semaphore-lock sem))))
|
||||
(error "Not a semaphore.")))
|
||||
|
||||
|
||||
;; Release a lock, if one is held or add 1 to the counter.
|
||||
(define (semaphore-post sem)
|
||||
(if (semaphore? sem)
|
||||
(begin
|
||||
(obtain-lock (get-semaphore-lock sem))
|
||||
(let ((waiting-list (get-semaphore-waiting sem)))
|
||||
(if (null? waiting-list)
|
||||
(begin
|
||||
(set-semaphore-counter! sem (+ 1 (get-semaphore-counter sem)))
|
||||
(release-lock (get-semaphore-lock sem)))
|
||||
(let ((locked-thread (car waiting-list)))
|
||||
(set-semaphore-waiting! sem (cdr waiting-list))
|
||||
(release-lock locked-thread)
|
||||
(release-lock (get-semaphore-lock sem))))))
|
||||
(error "Not a semaphore.")))
|
||||
|
||||
|
||||
;; Wait on the semaphore if the counter is 0
|
||||
(define (semaphore-wait sem)
|
||||
(if (semaphore? sem)
|
||||
(begin
|
||||
(obtain-lock (get-semaphore-lock sem))
|
||||
(if (> (get-semaphore-counter sem) 0)
|
||||
(begin
|
||||
(set-semaphore-counter! sem (- (get-semaphore-counter sem) 1))
|
||||
(release-lock (get-semaphore-lock sem)))
|
||||
(let ((lock (make-lock)))
|
||||
(set-semaphore-waiting! sem
|
||||
(cons lock (get-semaphore-waiting sem)))
|
||||
(obtain-lock lock)
|
||||
(release-lock (get-semaphore-lock sem))
|
||||
(obtain-lock lock))))
|
||||
(error "Not a semaphore.")))
|
||||
|
|
@ -1,364 +0,0 @@
|
|||
; -----------------------
|
||||
; --- SLIST/Blacklist ---
|
||||
; -----------------------
|
||||
|
||||
; SLIT-Structure for the recursiv lookup algorithm (resolver.scm).
|
||||
; The Blacklist is used to store 'bad' Nameserver-IPs.
|
||||
|
||||
; This file is part of the Scheme Untergrund Networking package
|
||||
|
||||
; Copyright (c) 2005/2006 by Norbert Freudemann
|
||||
; <nofreude@informatik.uni-tuebingen.de>
|
||||
|
||||
; For copyright information, see the file COPYING which comes with
|
||||
; the distribution.
|
||||
|
||||
; Naming-Scheme:
|
||||
; --------------
|
||||
|
||||
; dnsd-slist-...
|
||||
; dnsd-blacklist-...
|
||||
|
||||
;; SLIST-Cache
|
||||
|
||||
; The SLIST-Structure as described in RFC1034/1035.
|
||||
|
||||
; Lock-Safe Cache-Interface:
|
||||
; ---------------------------
|
||||
|
||||
; (dnsd-slist-clear!) - Removes the whole data.
|
||||
; (dnsd-slist-clean!) - Removes expired data.
|
||||
; (dnsd-slist-lookup msg dnsd-options) - Returns nameserver IPs.
|
||||
; (dnsd-slist-update! msg) - Stores Nameservers & their IPs.
|
||||
; (dnsd-slist-pretty-print) - Prints the slist.
|
||||
|
||||
|
||||
;; Blacklist:
|
||||
|
||||
; An IP-Adress can be blacklisted by bad resolver-results in resolver.scm
|
||||
; This will cause the increment a blacklist-value. After the value reaches
|
||||
; a threshold the IP will be ignored for some time (dnsd-options).
|
||||
;
|
||||
; After that, the next question for this IP can result in the following:
|
||||
; - ignore the IP another round for bad answer
|
||||
; - whitelist the IP for a good answer...
|
||||
; (A good result will remove any IP from the blacklist.)
|
||||
|
||||
; Lock-Safe Cache-Interface:
|
||||
; ---------------------------
|
||||
|
||||
; (dnsd-blacklist! ip . value) - Blacklist a IP.
|
||||
; (dnsd-blacklist-clean! dnsd-options)
|
||||
; (dnsd-blacklist-unlist! ip dnsd-options)
|
||||
; (dnsd-blacklist-clear!)
|
||||
; (dnsd-blacklist-print)
|
||||
|
||||
|
||||
; Stuff:
|
||||
; ------
|
||||
|
||||
; Filter rrs of the given type:
|
||||
; TYPE: message-type x list-of-rrs -> list-of-rrs
|
||||
(define (filter-rr-type type list)
|
||||
(filter (lambda (e) (eq? (resource-record-type e) type)) list))
|
||||
|
||||
(define *debug-info* #f)
|
||||
|
||||
; TODO: Do this different:
|
||||
; Shows the debug-information
|
||||
(define display-debug
|
||||
(lambda args
|
||||
(if *debug-info*
|
||||
(begin
|
||||
(display "dnsd: ")
|
||||
(map (lambda (e) (display e) (display " ")) args)
|
||||
(newline))
|
||||
#f)))
|
||||
|
||||
|
||||
; SLIST:
|
||||
; ------
|
||||
|
||||
(define-record-type dnsd-slist :dnsd-slist
|
||||
(make-dnsd-slist data lock)
|
||||
dnsd-slist?
|
||||
(data get-dnsd-slist-data) ; slist-data-record-type
|
||||
(lock get-dnsd-slist-lock)) ; r/w-lock
|
||||
|
||||
(define-record-type slist-data :slist-data
|
||||
(make-slist-data answer expires)
|
||||
cache?
|
||||
(answer slist-data-answer set-slist-data-answer!) ; list-of-rrs
|
||||
(expires slist-data-expires)) ; expiration time of the data (+ ttl (time))
|
||||
|
||||
|
||||
; Create the slist:
|
||||
(define *dnsd-slist* (make-dnsd-slist (make-string-table) (make-r/w-lock)))
|
||||
|
||||
|
||||
;; Search for the shortest TTL in the message:
|
||||
;; TYPE: message -> number or #f
|
||||
(define (dnsd-slist-find-shortest-ttl msg)
|
||||
(let loop ((msg msg))
|
||||
(cond
|
||||
((dns-message? msg) (loop (dns-message-reply msg)))
|
||||
((message? msg) (fold-right
|
||||
(lambda (e m)
|
||||
(let ((ttl (resource-record-ttl e)))
|
||||
(if m
|
||||
(if (<= m ttl) m ttl)
|
||||
ttl)))
|
||||
#f (message-additionals msg))))))
|
||||
|
||||
|
||||
;; Make a SLIST-Key from a message:
|
||||
;; TYPE: message -> key-string
|
||||
(define (make-slist-key msg)
|
||||
(let ((question (car (message-questions msg))))
|
||||
(format #f "~a;~a" (string-downcase (question-name question))
|
||||
(message-class-name (question-class question)))))
|
||||
|
||||
|
||||
;; Resets the SLIST:
|
||||
(define (dnsd-slist-clear!)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-slist-lock *dnsd-slist*)
|
||||
(lambda ()
|
||||
(set! *dnsd-slist* (make-dnsd-slist (make-string-table)
|
||||
(get-dnsd-slist-lock *dnsd-slist*))))))
|
||||
|
||||
|
||||
;; Removes expired data from the SLIST:
|
||||
(define (dnsd-slist-clean!)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-slist-lock *dnsd-slist*)
|
||||
(lambda ()
|
||||
(let ((time (time))
|
||||
(table (get-dnsd-slist-data *dnsd-slist*)))
|
||||
(table-walk (lambda (k e)
|
||||
(if (< time (slist-data-expires e))
|
||||
#t
|
||||
(table-set! table k #f)))
|
||||
table)))))
|
||||
|
||||
|
||||
;; Add the results of the given response to the cache-data
|
||||
;; a min ttl is given to the NS so that the rec-lookup-algorithm
|
||||
;; will be able to do it's work properly... .
|
||||
;; TYPE: message -> unspecific
|
||||
(define (dnsd-slist-update-ns! msg)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-slist-lock *dnsd-slist*)
|
||||
(lambda ()
|
||||
(and-let* ((key (make-slist-key msg)))
|
||||
(let* ((ttl (dnsd-slist-find-shortest-ttl msg))
|
||||
(min-ttl (if (< ttl 120) 120 ttl))
|
||||
(expires (+ (time) min-ttl)))
|
||||
(table-set!
|
||||
(get-dnsd-slist-data *dnsd-slist*)
|
||||
key
|
||||
(make-slist-data (message-additionals msg) expires)))))))
|
||||
|
||||
|
||||
; Take the nameservers & the corresponding IPs from a message and
|
||||
; (if no entry is present) adds the nameservers to the cache to be looked up
|
||||
; via the nameserver-zone (found as resource-record name of the servers)
|
||||
; Some server return nameserver resource records in the answer-section
|
||||
; others in the additional section.
|
||||
;; TYPE: message -> unspecific
|
||||
(define (dnsd-slist-update! msg)
|
||||
(display-debug "Updating SLIST! Adding a Nameserver.")
|
||||
(and-let* ((ns-rrs (append (message-answers msg) (message-nameservers msg)))
|
||||
(additionals (message-additionals msg))
|
||||
(good-ns-rrs (filter-rr-type (message-type ns) ns-rrs))
|
||||
(whatever (not (null? good-ns-rrs)))
|
||||
(good-additionals (filter-rr-type (message-type a) additionals))
|
||||
(whatever (not (null? good-additionals)))
|
||||
(class (question-class (car (message-questions msg))))
|
||||
(nameserver-zone (resource-record-name (car good-ns-rrs)))
|
||||
(good-ns-rrs (filter (lambda (e)
|
||||
(string-ci=? nameserver-zone
|
||||
(resource-record-name e)))
|
||||
good-ns-rrs))
|
||||
(nameserver-names (map (lambda (e)
|
||||
(resource-record-data-ns-name
|
||||
(resource-record-data e))) good-ns-rrs))
|
||||
(good-additionals (filter
|
||||
(lambda (e)
|
||||
(fold-right
|
||||
(lambda (name b)
|
||||
(if b b (string-ci=?
|
||||
name (resource-record-name e))))
|
||||
#f nameserver-names))
|
||||
good-additionals))
|
||||
(new-msg
|
||||
(make-message (message-header msg)
|
||||
(list (make-question nameserver-zone
|
||||
(message-type ns) class))
|
||||
good-ns-rrs '() good-additionals '())))
|
||||
(dnsd-slist-update-ns! new-msg)))
|
||||
|
||||
|
||||
;; Look for the IPs of the nameservers in the cache.
|
||||
;; TYPE: message -> list-of-address32
|
||||
(define (dnsd-slist-lookup msg dnsd-options)
|
||||
;; Look for data in the slist:
|
||||
(define (dnsd-slist-lookup-int msg)
|
||||
(let ((lock (get-dnsd-slist-lock *dnsd-slist*)))
|
||||
(obtain-R/w-lock lock)
|
||||
(let* ((data (get-dnsd-slist-data *dnsd-slist*))
|
||||
(key (make-slist-key msg))
|
||||
(cdata (table-ref data key)))
|
||||
(if cdata
|
||||
(if (< (time) (slist-data-expires cdata))
|
||||
(begin
|
||||
(let ((res (slist-data-answer cdata)))
|
||||
(release-R/w-lock lock)
|
||||
res))
|
||||
(begin
|
||||
(release-R/w-lock lock)
|
||||
(obtain-r/W-lock lock)
|
||||
(table-set! data key #f)
|
||||
(release-r/W-lock lock)
|
||||
#f))
|
||||
(begin (release-R/w-lock lock) #f)))))
|
||||
;; ---
|
||||
(and-let* ((additionals (dnsd-slist-lookup-int msg))
|
||||
(ns-a-rrs (filter-rr-type (message-type a) additionals))
|
||||
(ip-list (map (lambda (e) (resource-record-data-a-ip
|
||||
(resource-record-data e))) ns-a-rrs)))
|
||||
;; Filter good from blacklisted IPs:
|
||||
(with-R/w-lock
|
||||
(get-dnsd-blacklist-lock *blacklist*)
|
||||
(lambda ()
|
||||
(filter (lambda (ip)
|
||||
(let ((element (table-ref (get-dnsd-blacklist-data *blacklist*)
|
||||
ip)))
|
||||
(cond
|
||||
;; IP isn't in the blacklist-table
|
||||
((not element) #t)
|
||||
;; The IP hasn't been blacklisted blacklist-value-times
|
||||
((>= (dnsd-options-blacklist-value dnsd-options)
|
||||
(cdr element)) #t)
|
||||
;; Blacklisted longer than blacklist-time-value. Try again.
|
||||
((<= (+ (dnsd-options-blacklist-time dnsd-options)
|
||||
(car element))
|
||||
(time)) #t)
|
||||
;; Don't use the IP
|
||||
(else #f))))
|
||||
ip-list)))))
|
||||
|
||||
|
||||
|
||||
;; Blacklist:
|
||||
;; ----------
|
||||
|
||||
(define-record-type dnsd-blacklist :dnsd-blacklist
|
||||
(make-dnsd-blacklist data lock)
|
||||
dnsd-blacklist?
|
||||
(data get-dnsd-blacklist-data) ; a integer-table
|
||||
(lock get-dnsd-blacklist-lock)) ; r/w-lock
|
||||
|
||||
|
||||
(define *blacklist* (make-dnsd-blacklist (make-integer-table) (make-r/w-lock)))
|
||||
|
||||
|
||||
;; Add a IP to the blacklist:
|
||||
;; TYPE: address32 -> unspecific
|
||||
(define (dnsd-blacklist! ip . value)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-blacklist-lock *blacklist*)
|
||||
(lambda ()
|
||||
(let* ((table (get-dnsd-blacklist-data *blacklist*))
|
||||
(element (table-ref table ip))
|
||||
(value (if (null? value)
|
||||
1
|
||||
(car value))))
|
||||
(if element
|
||||
(table-set! table ip (cons (time) (+ value (cdr element))))
|
||||
(table-set! table ip (cons (time) value)))))))
|
||||
|
||||
|
||||
;; Removes the given ip from the list:
|
||||
;; TYPE address32 -> unspecific
|
||||
(define (dnsd-blacklist-unlist! ip dnsd-options)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-blacklist-lock *blacklist*)
|
||||
(lambda ()
|
||||
(let ((blacklist (get-dnsd-blacklist-data *blacklist*)))
|
||||
(if (and (table-ref blacklist ip)
|
||||
(< (cdr (table-ref blacklist ip))
|
||||
(dnsd-options-blacklist-value dnsd-options)))
|
||||
(table-set! blacklist ip #f)
|
||||
#f)))))
|
||||
|
||||
|
||||
;; Remove all blacklisted IPs:
|
||||
(define (dnsd-blacklist-clear!)
|
||||
(with-r/W-lock
|
||||
(get-dnsd-blacklist-lock *blacklist*)
|
||||
(lambda ()
|
||||
(set! *blacklist* (make-dnsd-blacklist
|
||||
(make-integer-table)
|
||||
(get-dnsd-blacklist-lock *blacklist*))))))
|
||||
|
||||
|
||||
;; Deprecated:
|
||||
;; Remove old entries:
|
||||
; (define (dnsd-blacklist-clean! dnsd-options)
|
||||
; (with-r/W-lock
|
||||
; (get-dnsd-blacklist-lock *blacklist*)
|
||||
; (lambda ()
|
||||
; (table-walk
|
||||
; (lambda (key element)
|
||||
; (if (< (dnsd-options-blacklist-time dnsd-options)
|
||||
; (- (time) (car element)))
|
||||
; (table-set! (get-dnsd-blacklist-data *blacklist*) key #f)))
|
||||
; (get-dnsd-blacklist-data *blacklist*)))))
|
||||
|
||||
|
||||
;; Display SLIST / Blacklist:
|
||||
;; --------------------------
|
||||
|
||||
;; Display the blacklisted IPs:
|
||||
(define (dnsd-blacklist-print)
|
||||
(with-R/w-lock
|
||||
(get-dnsd-blacklist-lock *blacklist*)
|
||||
(lambda ()
|
||||
(let ((data (get-dnsd-blacklist-data *blacklist*))
|
||||
(current-time (time)))
|
||||
(display "DNSD-Blacklist:\n")
|
||||
(display "---------------\n")
|
||||
(table-walk
|
||||
(lambda (key element)
|
||||
(display "\nIP: ")
|
||||
(display (address32->ip-string key))
|
||||
(display " with blacklist-value: ")
|
||||
(display (cdr element))
|
||||
(display " [with age ")
|
||||
(display (- current-time (car element)))
|
||||
(display "s.]")
|
||||
(newline))
|
||||
data)))))
|
||||
|
||||
;; Display the SLIST:
|
||||
(define (dnsd-slist-pretty-print)
|
||||
(with-R/w-lock
|
||||
(get-dnsd-slist-lock *dnsd-slist*)
|
||||
(lambda ()
|
||||
(let ((data (get-dnsd-slist-data *dnsd-slist*)))
|
||||
(display "DNSD-SLIST:\n")
|
||||
(display "-----------\n")
|
||||
(table-walk
|
||||
(lambda (k e)
|
||||
(let ((slist-data (slist-data-answer e)))
|
||||
(display "\n*Zone: ")
|
||||
(display k)(newline)
|
||||
(display " ---------\n")
|
||||
(display " Expires in: ")
|
||||
(display (- (slist-data-expires e) (time)))
|
||||
(display " seconds.\n")
|
||||
(display " \n Nameservers-Section:\n\n")
|
||||
(map (lambda (y) (pretty-print-dns-message y))
|
||||
slist-data)))
|
||||
data)))))
|
||||
1386
scheme/ftpd/ftpd.scm
1386
scheme/ftpd/ftpd.scm
File diff suppressed because it is too large
Load Diff
|
|
@ -1,76 +0,0 @@
|
|||
;;; http server in the Scheme Shell -*- Scheme -*-
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
|
||||
;;; Copyright (c) 1996 by Mike Sperber. <sperber@informatik.uni-tuebingen.de>
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
;;; This code is very rudimentary at the moment and up for some expansion.
|
||||
;;; Right now, it is primarily useful for running the server through a
|
||||
;;; web accelerator
|
||||
|
||||
(define (access-denier . hosts)
|
||||
(lambda (info)
|
||||
(and (any (lambda (host)
|
||||
(host-matches? info host))
|
||||
hosts)
|
||||
'deny)))
|
||||
|
||||
(define (access-allower . hosts)
|
||||
(lambda (info)
|
||||
(and (any (lambda (host)
|
||||
(host-matches? info host))
|
||||
hosts)
|
||||
'allow)))
|
||||
|
||||
(define (access-controller . controls)
|
||||
(lambda (info)
|
||||
(let loop ((controls controls))
|
||||
(and (pair? controls)
|
||||
(or ((car controls) info)
|
||||
(loop (cdr controls)))))))
|
||||
|
||||
(define (access-controlled-handler control ph)
|
||||
(lambda (path req)
|
||||
(if (eq?
|
||||
(control (host-info (socket-remote-address (request-socket req))))
|
||||
'deny)
|
||||
(http-error (status-code forbidden) req)
|
||||
(ph path req))))
|
||||
|
||||
(define (address->list address)
|
||||
(list (arithmetic-shift (bitwise-and address #xff000000) -24)
|
||||
(arithmetic-shift (bitwise-and address #xff0000) -16)
|
||||
(arithmetic-shift (bitwise-and address #xff00) -8)
|
||||
(bitwise-and address #xff)))
|
||||
|
||||
(define (host-matches? info host)
|
||||
(cond
|
||||
((list? host)
|
||||
(let ((len (length host)))
|
||||
(any (lambda (address)
|
||||
(equal? (take len (address->list address)) host))
|
||||
(host-info:addresses info))))
|
||||
(else ; (string? host)
|
||||
(any (lambda (name)
|
||||
(string-match host (string-map char-downcase name)))
|
||||
(cons (host-info:name info)
|
||||
(host-info:aliases info))))))
|
||||
|
||||
(define normalize-host
|
||||
(let ((split (infix-splitter (make-regexp "\\.")))
|
||||
(number (make-regexp "[0-9]+")))
|
||||
(lambda (host)
|
||||
(let ((components (split host)))
|
||||
(if (every (lambda (component)
|
||||
(regexp-exec number component))
|
||||
components)
|
||||
(map string->number components)
|
||||
host)))))
|
||||
|
||||
(define (take n l)
|
||||
(let loop ((n n) (l l) (r '()))
|
||||
(if (zero? n)
|
||||
(reverse r)
|
||||
(loop (- n 1) (cdr l) (cons (car l) r)))))
|
||||
|
|
@ -1,300 +0,0 @@
|
|||
;;; Server support for NCSA's WWW Common Gateway Interface -*- Scheme -*-
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
|
||||
|
||||
;;; PROBLEMS:
|
||||
;;; - The handlers could be made -- closed over their parameters
|
||||
;;; (e.g., root vars, etc.)
|
||||
|
||||
;;; This code provides a request handler for the HTTP server that implements
|
||||
;;; a CGI interface to external programs for doing HTTP transactions.
|
||||
|
||||
;;; About HTML forms
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This info is in fact independent of CGI, but important to know about,
|
||||
;;; as many CGI scripts are written for responding to forms-entry in
|
||||
;;; HTML browsers.
|
||||
;;;
|
||||
;;; The form's field data are turned into a single string, of the form
|
||||
;;; name=val&name=val
|
||||
;;; where the <name> and <val> parts are URI encoded to hide their
|
||||
;;; &, =, and + chars, among other things. After URI encoding, the
|
||||
;;; space chars are converted to + chars, just for fun. It is important
|
||||
;;; to encode the spaces this way, because the perfectly general %xx escape
|
||||
;;; mechanism might be insufficiently confusing. This variant encoding is
|
||||
;;; called "form-url encoding."
|
||||
;;;
|
||||
;;; If the form's method is POST,
|
||||
;;; Browser sends the form's field data in the entity block, e.g.,
|
||||
;;; "button=on&ans=yes". The request's Content-type: is application/
|
||||
;;; x-www-form-urlencoded, and the request's Content-length: is the
|
||||
;;; number of bytes in the form data.
|
||||
;;;
|
||||
;;; If the form's method is GET,
|
||||
;;; Browser sends the form's field data in the URL's <search> part.
|
||||
;;; (So the server will pass to the CGI script as $QUERY_STRING,
|
||||
;;; and perhaps also on in argv[]).
|
||||
;;;
|
||||
;;; In either case, the data is "form-url encoded" (as described above).
|
||||
|
||||
;;; ISINDEX queries:
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; (Likewise for ISINDEX URL queries from browsers.)
|
||||
;;; Browser url-form encodes the query (see above), which then becomes the
|
||||
;;; ?<search> part of the URI. (Hence the CGI script will split the individual
|
||||
;;; fields into argv[].)
|
||||
|
||||
|
||||
;;; CGI interface:
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
|
||||
;;; - If it contains no raw "=" chars, it is split at "+" chars. The
|
||||
;;; substrings are URI decoded, and become the elts of argv[].
|
||||
;;; - The CGI script is run with stdin hooked up to the socket. If it's going
|
||||
;;; to read the entity, it should read $CONTENT_LENGTH bytes worth.
|
||||
;;; - A bunch of env vars are set; see below.
|
||||
;;; - If the script begins with "nph-" its output is the entire response.
|
||||
;;; Otherwise, it replies to the server, we peel off a little header
|
||||
;;; that is used to construct the real header for the response.
|
||||
;;; See the "spec" for further details. (URL above).
|
||||
;;;
|
||||
;;; The "spec" also talks about PUT, but when I tried this on a dummy script,
|
||||
;;; the NSCA httpd server generated buggy output. So I am only implementing
|
||||
;;; the POST and GET ops; any other op generates a "405 Method not allowed"
|
||||
;;; response.
|
||||
|
||||
;;; Parameters
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; path for scripts
|
||||
(define cgi-default-bin-path "/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin")
|
||||
|
||||
;;; The request handler for CGI scripts. (car path) is the script to run.
|
||||
;;; cgi-bin-path is used, if PATH-variable isn't defined
|
||||
|
||||
(define (cgi-handler bin-dir . maybe-cgi-bin-path)
|
||||
(let-optionals
|
||||
maybe-cgi-bin-path
|
||||
((cgi-bin-path cgi-default-bin-path))
|
||||
|
||||
(let ((request-invariant-cgi-env ; environment variables that never change
|
||||
`(("PATH" . ,cgi-bin-path)
|
||||
("SERVER_SOFTWARE" . ,sunet-version-identifier)
|
||||
("SERVER_NAME" . ,(host-info:name (host-info (system-name))))
|
||||
("GATEWAY_INTERFACE" . "CGI/1.1"))))
|
||||
(lambda (path req)
|
||||
(if (pair? path) ; Got to have at least one elt.
|
||||
(compute-cgi path req bin-dir request-invariant-cgi-env)
|
||||
(make-error-response (status-code bad-request) req "Empty CGI script"))))))
|
||||
|
||||
(define (compute-cgi path req bin-dir request-invariant-cgi-env)
|
||||
(let* ((prog (car path))
|
||||
|
||||
(filename (or (dotdot-check bin-dir (list prog))
|
||||
(http-error (status-code bad-request) req
|
||||
"CGI scripts may not contain \"..\" elements.")))
|
||||
|
||||
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
|
||||
; why did we had (string-suffix? "-nph" prog) here?
|
||||
|
||||
(search (http-url-search (request-url req))) ; Compute the
|
||||
(argv (if (and search (not (string-index search #\=))) ; argv list.
|
||||
(split-and-decode-search-spec search)
|
||||
'()))
|
||||
|
||||
(env (cgi-env req bin-dir (cdr path) request-invariant-cgi-env))
|
||||
|
||||
(doit (lambda ()
|
||||
(dup->inport (socket:inport (request-socket req)) 0)
|
||||
(dup->outport (current-output-port) 1)
|
||||
(dup 1 2)
|
||||
(apply exec/env filename env argv))))
|
||||
|
||||
(http-syslog (syslog-level debug) "[cgi-server] search: ~s, argv: ~s~%" search argv)
|
||||
(let ((request-method (request-method req)))
|
||||
(cond
|
||||
((or (string=? request-method "GET")
|
||||
(string=? request-method "POST")) ; Could do others also.
|
||||
(case (file-not-executable? filename)
|
||||
((search-denied permission)
|
||||
(make-error-response (status-code forbidden) req
|
||||
"Permission denied."))
|
||||
((no-directory nonexistent)
|
||||
(make-error-response (status-code not-found) req
|
||||
"File or directory doesn't exist."))
|
||||
(else
|
||||
(if nph?
|
||||
(cgi-make-nph-response (run/port* doit))
|
||||
(cgi-make-response (run/port* doit) path req)))))
|
||||
|
||||
(else
|
||||
(make-error-response (status-code method-not-allowed) req request-method))))))
|
||||
|
||||
|
||||
(define (split-and-decode-search-spec s)
|
||||
(let recur ((i 0))
|
||||
(cond
|
||||
((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||
(recur (+ j 1)))))
|
||||
(else (list (unescape-uri s i (string-length s)))))))
|
||||
|
||||
|
||||
;;; Compute the CGI scripts' process environment by adding the standard CGI
|
||||
;;; environment var bindings to the current process env -- return result
|
||||
;;; as an alist.
|
||||
;;;
|
||||
;;; You are also supposed to add the headers as env vars in a particular
|
||||
;;; format, but are allowed to bag it if the environment var storage
|
||||
;;; requirements might overload the OS. I don't know what you can rely upon
|
||||
;;; in Unix, so I am just bagging it, period.
|
||||
;;;
|
||||
;;; Suppose the URL is
|
||||
;;; //machine/cgi-bin/test-script/foo/bar?quux%20a+b=c
|
||||
;;; then:
|
||||
;; PATH_INFO -- extra info after the script-name path prefix. "/foo/bar"
|
||||
;;; PATH_TRANSLATED -- non-virtual version of above. "/u/Web/foo/bar/"
|
||||
;;; SCRIPT_NAME virtual path to script "/cgi-bin/test-script"
|
||||
;;; QUERY_STRING -- not decoded "quux%20a+b=c"
|
||||
;;; The first three of these vars are *not* encoded, so information is lost
|
||||
;;; if the URL's path elements contain encoded /'s (%2F). CGI loses.
|
||||
|
||||
(define (cgi-env req bin-dir path-suffix request-invariant-cgi-env)
|
||||
(let* ((sock (request-socket req))
|
||||
(raddr (socket-remote-address sock))
|
||||
|
||||
(headers (request-headers req))
|
||||
|
||||
;; Compute the $PATH_INFO and $PATH_TRANSLATED strings.
|
||||
(path-info (uri-path->uri path-suffix)) ; No encode or .. check.
|
||||
(path-translated (path-list->file-name path-info bin-dir))
|
||||
|
||||
;; Compute the $SCRIPT_PATH string.
|
||||
(url-path (http-url-path (request-url req)))
|
||||
(script-path (take (- (length url-path) (length path-suffix))
|
||||
url-path))
|
||||
(script-name (uri-path->uri script-path)))
|
||||
|
||||
(receive (rhost rport)
|
||||
(socket-address->internet-address raddr)
|
||||
(receive (lhost lport)
|
||||
(socket-address->internet-address (socket-local-address sock))
|
||||
|
||||
`(("SERVER_PROTOCOL" . ,(version->string (request-version req)))
|
||||
("SERVER_PORT" . ,(number->string lport))
|
||||
("REQUEST_METHOD" . ,(request-method req))
|
||||
|
||||
("PATH_INFO" . ,path-info)
|
||||
("PATH_TRANSLATED" . ,path-translated)
|
||||
("SCRIPT_NAME" . ,script-name)
|
||||
|
||||
("REMOTE_ADDR" . ,(format-internet-host-address rhost))
|
||||
|
||||
;; ("AUTH_TYPE" . xx) ; Random authentication
|
||||
;; ("REMOTE_USER" . xx) ; features I don't understand.
|
||||
;; ("REMOTE_IDENT" . xx)
|
||||
|
||||
,@request-invariant-cgi-env ; Stuff that never changes (see cgi-handler).
|
||||
|
||||
,@(cond ((http-url-search (request-url req)) =>
|
||||
(lambda (srch) `(("QUERY_STRING" . ,srch))))
|
||||
(else '()))
|
||||
|
||||
,@(cond ((get-header headers 'content-type) =>
|
||||
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
|
||||
(else '()))
|
||||
|
||||
,@(cond ((get-header headers 'content-length) =>
|
||||
(lambda (cl) ; Skip initial whitespace (& other non-digits).
|
||||
(let ((first-digit (string-index cl char-set:digit))
|
||||
(cl-len (string-length cl)))
|
||||
(if first-digit
|
||||
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
|
||||
(http-error (status-code bad-request) req
|
||||
"Illegal `Content-length:' header.")))))
|
||||
|
||||
(else '()))
|
||||
|
||||
. ,(env->alist))))))
|
||||
|
||||
|
||||
(define (take n lis)
|
||||
(if (zero? n) '()
|
||||
(cons (car lis) (take (- n 1) (cdr lis)))))
|
||||
|
||||
(define (drop n lis)
|
||||
(if (zero? n) lis
|
||||
(drop (- n 1) (cdr lis))))
|
||||
|
||||
|
||||
;;; Script's output for request REQ is available on SCRIPT-PORT.
|
||||
;;; The script isn't an "nph-" script, so we read the response, and mutate
|
||||
;;; it into a real HTTP response, which we then send back to the HTTP client.
|
||||
|
||||
(define (cgi-make-response script-port path req)
|
||||
(set-port-buffering script-port bufpol/block 4096)
|
||||
(let* ((headers (read-rfc822-headers script-port))
|
||||
(ctype (get-header headers 'content-type))
|
||||
(loc (get-header headers 'location))
|
||||
(stat (cond ((get-header headers 'status)
|
||||
=> (lambda (code.text)
|
||||
(extract-status-code-and-text code.text
|
||||
req)))
|
||||
(else
|
||||
(http-syslog (syslog-level notice)
|
||||
"CGI script didn't generate status header.")
|
||||
(cons 200 "OK"))))
|
||||
(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)
|
||||
(or ctype "text/html")
|
||||
extra-headers
|
||||
(make-writer-body
|
||||
(lambda (out options)
|
||||
(copy-inport->outport script-port out 4096)
|
||||
(close-input-port script-port)))))))
|
||||
|
||||
(define (delete-headers headers tag)
|
||||
(alist-delete tag headers))
|
||||
|
||||
(define (cgi-make-nph-response script-port)
|
||||
(make-nph-response
|
||||
(make-writer-body (lambda (out options)
|
||||
(copy-inport->outport script-port out)))))
|
||||
|
||||
(define (uri-has-protocol? loc)
|
||||
(receive (proto path search frag)
|
||||
(parse-uri loc)
|
||||
(if proto #t #f)))
|
||||
|
||||
(define (extract-status-code-and-text status req)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (c d)
|
||||
(http-error (status-code bad-gateway) req
|
||||
"CGI script generated an invalid status header."
|
||||
status c))
|
||||
(lambda ()
|
||||
(let ((status (string-trim status)))
|
||||
(cons (string->number (substring status 0 3)) ; number
|
||||
(substring/shared status 4)))))) ; text
|
||||
|
|
@ -1,376 +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-prepare-listen-accept-loop
|
||||
protocol-family/internet
|
||||
(lambda ()
|
||||
(cond ((httpd-options-post-bind-thunk options)
|
||||
=> (lambda (thunk)
|
||||
(thunk)))))
|
||||
(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/block 4096)
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
;; If there is buffering for the input,
|
||||
;; CGI scripts don't get the full request
|
||||
(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 occurred while processing request"
|
||||
c)))
|
||||
(else
|
||||
(decline))))
|
||||
(lambda ()
|
||||
(let ((initial-req (parse-http-request sock options)))
|
||||
(let redirect-loop ((req initial-req))
|
||||
(let response-loop ((response ((httpd-options-request-handler options)
|
||||
(http-url-path (request-url req))
|
||||
req)))
|
||||
(cond
|
||||
((input-response? response)
|
||||
(response-loop
|
||||
((input-response-body-maker response)
|
||||
(socket:inport sock))))
|
||||
((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 Request Line."))))
|
||||
(meth (car elts))
|
||||
(uri-string (cadr elts))
|
||||
(url (parse-http-servers-url-fragment uri-string sock options))
|
||||
(headers (if (equal? version '(0 . 9))
|
||||
'()
|
||||
(read-rfc822-headers (socket:inport sock)))))
|
||||
(make-request meth uri-string url version headers sock)))))
|
||||
|
||||
;;; Parse the URL, but if it begins without the "http://host:port"
|
||||
;;; prefix, interpolate one from SOCKET. It would be sleazier but
|
||||
;;; faster if we just computed the default host and port at
|
||||
;;; server-startup time, instead of on every request.
|
||||
;;; REDIRECT-REQUEST relys on that nothing is read out from SOCKET.
|
||||
|
||||
(define (parse-http-servers-url-fragment uri-string socket options)
|
||||
(receive (scheme path search frag-id) (parse-uri uri-string)
|
||||
(if frag-id ; Can't have a #frag part.
|
||||
(fatal-syntax-error "HTTP URL contains illegal #<fragment> suffix."
|
||||
uri-string)
|
||||
|
||||
(if scheme
|
||||
(if (string-ci=? scheme "http") ; Better be an http url.
|
||||
(parse-http-url path search #f)
|
||||
(fatal-syntax-error "Non-HTTP URL" uri-string))
|
||||
|
||||
;; Interpolate the server struct from our net connection.
|
||||
(if (and (pair? path) (string=? (car path) ""))
|
||||
(let* ((addr (socket-local-address socket))
|
||||
(local-name (or (httpd-options-fqdn options)
|
||||
(socket-address->fqdn addr)))
|
||||
(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
|
||||
;;if request-record could not be built (i.e. either
|
||||
;;fatal-syntax-error was called because of an erroneous request
|
||||
;;line, or an server-internal error (not an os-error) occurred)
|
||||
;;and therefore HTTP-version of request is not known, answer
|
||||
;;with HTTP/1.0
|
||||
((not request)
|
||||
(send-http-headers response output-port)
|
||||
(display-http-body (response-body response) input-port output-port options))
|
||||
;;no CLF-logging)
|
||||
((nph-response? response)
|
||||
(display-http-body (nph-response-body response) input-port output-port options)
|
||||
(http-log request (status-code ok))); guess the status code
|
||||
(else
|
||||
(if (not (v0.9-request? request))
|
||||
(send-http-headers response output-port))
|
||||
(if (not (string=? (request-method request) "HEAD"))
|
||||
(display-http-body (response-body response) input-port output-port options))
|
||||
(http-log request (response-code response)))))
|
||||
|
||||
(define (send-http-header-fields headers port)
|
||||
(for-each (lambda (pair)
|
||||
(display (car pair) port)
|
||||
(write-char #\: port)
|
||||
(display (cdr pair) port)
|
||||
(write-crlf port))
|
||||
headers))
|
||||
|
||||
(define (my-reported-port addr)
|
||||
(receive (ip-addr portnum) (socket-address->internet-address addr)
|
||||
portnum))
|
||||
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
;;; Error stuff for the http server. -*- Scheme -*-
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
;;; An http error condition is a data structure with the following pieces:
|
||||
;;; (error-code request message . irritants)
|
||||
;;; You recognise one with HTTP-ERROR?, and retrieve the pieces with
|
||||
;;; CONDITION-STUFF.
|
||||
;;;
|
||||
|
||||
;;; HTTP error condition
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Define a sub-type of the S48 error condition, the HTTP error condition.
|
||||
;;; An HTTP error is one that corresponds to one of the HTTP error response
|
||||
;;; codes, so you can reliably use an HTTP error condition to construct an
|
||||
;;; error response message to send back to the HTTP client.
|
||||
|
||||
(define-condition-type 'http-error '(error))
|
||||
|
||||
(define http-error? (condition-predicate 'http-error))
|
||||
|
||||
(define (http-error status-code req . args)
|
||||
(apply signal 'http-error status-code req args))
|
||||
|
||||
;;; Syntax error condition
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Scheme 48 has a "syntax error" error condition, but it isn't an error
|
||||
;;; condition! It's a warning condition. I don't understand this.
|
||||
;;; We define a *fatal* syntax error here for the parsers to use.
|
||||
|
||||
(define-condition-type 'fatal-syntax-error '(error))
|
||||
|
||||
(define fatal-syntax-error? (condition-predicate 'fatal-syntax-error))
|
||||
|
||||
(define (fatal-syntax-error msg . irritants)
|
||||
(apply signal 'fatal-syntax-error msg irritants))
|
||||
|
||||
|
|
@ -1,540 +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-2003 by Mike Sperber.
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
(define server/buffer-size 8192) ; WTF
|
||||
|
||||
(define-record-type file-directory-options :file-directory-options
|
||||
(really-make-file-directory-options file-name->content-type
|
||||
file-name->content-encoding
|
||||
file-name->icon-url
|
||||
directory-icon-url
|
||||
blank-icon-url
|
||||
back-icon-url
|
||||
unknown-icon-url)
|
||||
file-directory-options?
|
||||
(file-name->content-type file-directory-options-file-name->content-type
|
||||
set-file-directory-options-file-name->content-type!)
|
||||
(file-name->content-encoding file-directory-options-file-name->content-encoding
|
||||
set-file-directory-options-file-name->content-encoding!)
|
||||
(file-name->icon-url file-directory-options-file-name->icon-url
|
||||
set-file-directory-options-file-name->icon-url!)
|
||||
(directory-icon-url file-directory-options-directory-icon-url
|
||||
set-file-directory-options-directory-icon-url!)
|
||||
(blank-icon-url file-directory-options-blank-icon-url
|
||||
set-file-directory-options-blank-icon-url!)
|
||||
(back-icon-url file-directory-options-back-icon-url
|
||||
set-file-directory-options-back-icon-url!)
|
||||
(unknown-icon-url file-directory-options-unknown-icon-url
|
||||
set-file-directory-options-unknown-icon-url!))
|
||||
|
||||
(define (make-default-file-directory-options)
|
||||
(really-make-file-directory-options default-file-name->content-type
|
||||
default-file-name->content-encoding
|
||||
default-file-name->icon-url
|
||||
#f #f #f #f))
|
||||
|
||||
(define (copy-file-directory-options options)
|
||||
(let ((new-options (make-default-file-directory-options)))
|
||||
(set-file-directory-options-file-name->content-type!
|
||||
new-options
|
||||
(file-directory-options-file-name->content-type options))
|
||||
(set-file-directory-options-file-name->content-encoding!
|
||||
new-options
|
||||
(file-directory-options-file-name->content-encoding options))
|
||||
(set-file-directory-options-file-name->icon-url!
|
||||
new-options
|
||||
(file-directory-options-file-name->icon-url options))
|
||||
(set-file-directory-options-directory-icon-url!
|
||||
new-options
|
||||
(file-directory-options-directory-icon-url options))
|
||||
(set-file-directory-options-blank-icon-url!
|
||||
new-options
|
||||
(file-directory-options-blank-icon-url options))
|
||||
(set-file-directory-options-back-icon-url!
|
||||
new-options
|
||||
(file-directory-options-back-icon-url options))
|
||||
(set-file-directory-options-unknown-icon-url!
|
||||
new-options
|
||||
(file-directory-options-unknown-icon-url options))
|
||||
new-options))
|
||||
|
||||
(define (make-file-directory-options-transformer set-option!)
|
||||
(lambda (new-value . stuff)
|
||||
(let ((new-options (if (not (null? stuff))
|
||||
(copy-file-directory-options (car stuff))
|
||||
(make-default-file-directory-options))))
|
||||
(set-option! new-options new-value)
|
||||
new-options)))
|
||||
|
||||
(define with-file-name->content-type
|
||||
(make-file-directory-options-transformer
|
||||
set-file-directory-options-file-name->content-type!))
|
||||
(define with-file-name->content-encoding
|
||||
(make-file-directory-options-transformer
|
||||
set-file-directory-options-file-name->content-encoding!))
|
||||
(define with-file-name->icon-url
|
||||
(make-file-directory-options-transformer
|
||||
set-file-directory-options-file-name->icon-url!))
|
||||
(define with-blank-icon-url
|
||||
(make-file-directory-options-transformer
|
||||
set-file-directory-options-blank-icon-url!))
|
||||
(define with-back-icon-url
|
||||
(make-file-directory-options-transformer
|
||||
set-file-directory-options-back-icon-url!))
|
||||
(define with-unknown-icon-url
|
||||
(make-file-directory-options-transformer
|
||||
set-file-directory-options-unknown-icon-url!))
|
||||
|
||||
(define (make-file-directory-options . stuff)
|
||||
(let loop ((options (make-default-file-directory-options))
|
||||
(stuff stuff))
|
||||
(if (null? stuff)
|
||||
options
|
||||
(let* ((transformer (car stuff))
|
||||
(value (cadr stuff)))
|
||||
(loop (transformer value options)
|
||||
(cddr stuff))))))
|
||||
|
||||
;;; (home-dir-handler user-public-dir) -> handler
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Return a request handler that looks things up in a specific directory
|
||||
;;; in the user's home directory. If ph = (home-dir-handler "public_html")
|
||||
;;; then ph is a request handler that serves files out of peoples' public_html
|
||||
;;; subdirectory. So
|
||||
;;; (ph '("shivers" "hk.html") req)
|
||||
;;; will serve the file
|
||||
;;; ~shivers/public_html/hk.html
|
||||
;;; The request handler treats the URL path as (<user> . <file-path>),
|
||||
;;; serving
|
||||
;;; ~<user>/<user-public-dir>/<file-path>
|
||||
|
||||
(define (home-dir-handler user-public-dir . maybe-options)
|
||||
(let-optionals maybe-options ((options (make-default-file-directory-options)))
|
||||
(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
|
||||
options)))))
|
||||
|
||||
;;; (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 . maybe-options)
|
||||
(let-optionals maybe-options ((options (make-default-file-directory-options)))
|
||||
(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
|
||||
options)))
|
||||
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 . maybe-options)
|
||||
(let-optionals maybe-options ((options (make-default-file-directory-options)))
|
||||
(lambda (path req)
|
||||
(make-rooted-file-path-response root path file-serve-response req options))))
|
||||
|
||||
;;; Dito, but also serve directory indices for directories without
|
||||
;;; index.html.
|
||||
|
||||
(define (rooted-file-or-directory-handler root . maybe-options)
|
||||
(let-optionals maybe-options ((options (make-default-file-directory-options)))
|
||||
(lambda (path req)
|
||||
(make-rooted-file-path-response root path
|
||||
file-serve-and-dir-response
|
||||
req
|
||||
options))))
|
||||
|
||||
|
||||
;;;; Support procs for the path handlers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req options)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Do a request for a file. The file-name is determined by appending the
|
||||
;;; the FILE-PATH list the string ROOT. E.g., if
|
||||
;;; ROOT = "/usr/shivers" FILE-PATH = ("a" "b" "c" "foo.html")
|
||||
;;; then we serve file
|
||||
;;; /usr/shivers/a/b/c/foo.html
|
||||
;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
|
||||
;;; (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path
|
||||
;;; sequences are processed away by the browser when the URI is converted
|
||||
;;; to an absolute URI before it is sent off to the server.)
|
||||
;;; It is possible to sneak a .. past this kind of front-end resolving by
|
||||
;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
|
||||
;;; this, MAKE-ROOTED-FILE-PATH-RESPONSE will catch it, and abort the transaction.
|
||||
;;; So you cannot make the reference back up past ROOT. E.g., this is
|
||||
;;; not allowed:
|
||||
;;; FILE-PATH = ("a" "../.." "c" "foo.html")
|
||||
;;;
|
||||
;;; Only GET and HEAD ops are provided.
|
||||
;;; The URL's <search> component must be #f.
|
||||
;;; The file is served if the server has read or stat(2) access to it,
|
||||
;;; respectively. If the server is run as root, this might be a problem.
|
||||
;;;
|
||||
;;; FILE-SERVE is a procedure which gets passed the file name, the
|
||||
;;; path, and the HTTP request to serve the file propert after the
|
||||
;;; security checks. Look in ROOTED-FILE-HANDLER and
|
||||
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
|
||||
|
||||
(define (make-rooted-file-path-response root file-path file-serve-response req options)
|
||||
(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 options)))
|
||||
(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 options)
|
||||
(if (file-name-directory? fname) ; Simple index generation.
|
||||
(directory-serve-response fname file-path req options)
|
||||
|
||||
(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 options))
|
||||
|
||||
((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 options)
|
||||
(file-serve-response (string-append fname "index.html") file-path req options))
|
||||
|
||||
(define (file-serve-response fname file-path req options)
|
||||
(file-serve-or-dir-response fname file-path req
|
||||
directory-index-serve-response
|
||||
options))
|
||||
|
||||
(define (default-file-name->icon-url fname)
|
||||
#f)
|
||||
|
||||
(define (time->directory-index-date-string time)
|
||||
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
|
||||
|
||||
(define (read-max-lines fname max)
|
||||
(call-with-input-file
|
||||
fname
|
||||
(lambda (port)
|
||||
(let loop ((r "") (i max))
|
||||
(if (zero? i)
|
||||
r
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
r
|
||||
(loop (string-append r " " line) (- i 1)))))))))
|
||||
|
||||
(define (string-cut s n)
|
||||
(if (>= (string-length s) n)
|
||||
(substring s 0 n)
|
||||
s))
|
||||
|
||||
(define html-file-header
|
||||
(let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
|
||||
(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
|
||||
(lambda (fname n)
|
||||
(let ((stuff (read-max-lines fname 10)))
|
||||
(cond
|
||||
((regexp-exec title-tag-regexp stuff)
|
||||
=> (lambda (open-match)
|
||||
(cond
|
||||
((regexp-exec title-close-tag-regexp stuff
|
||||
(match:end open-match 0))
|
||||
=> (lambda (close-match)
|
||||
(string-cut (substring stuff
|
||||
(match:end open-match 0)
|
||||
(match:start close-match 0))
|
||||
n)))
|
||||
(else (string-cut (substring stuff
|
||||
(match:end open-match 0)
|
||||
(string-length stuff))
|
||||
n)))))
|
||||
(else ""))))))
|
||||
|
||||
(define (file-documentation fname n options)
|
||||
(cond
|
||||
(((file-directory-options-file-name->content-type options) 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 port options)
|
||||
|
||||
(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))
|
||||
(icon-name
|
||||
(case type
|
||||
((regular fifo socket)
|
||||
((file-directory-options-file-name->icon-url options)
|
||||
fname))
|
||||
((directory)
|
||||
(file-directory-options-directory-icon-url options))
|
||||
(else
|
||||
(file-directory-options-unknown-icon-url options))))
|
||||
(tag-name
|
||||
(case type
|
||||
((regular fifo socket) "[FILE]")
|
||||
((directory) "[DIR ]")
|
||||
(else "[????]"))))
|
||||
(if icon-name
|
||||
(emit-tag port 'img
|
||||
(cons 'src icon-name)
|
||||
(cons 'alt tag-name))
|
||||
(display tag-name port))
|
||||
(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 options) port)
|
||||
(write-crlf port)))
|
||||
|
||||
(let ((files (directory-files dir)))
|
||||
(for-each index-entry files)
|
||||
(length files)))
|
||||
|
||||
(define (directory-serve-response fname file-path req options)
|
||||
(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 httpd-options)
|
||||
(let ((back-icon
|
||||
(file-directory-options-back-icon-url options))
|
||||
(blank-icon
|
||||
(file-directory-options-blank-icon-url options)))
|
||||
(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 ()
|
||||
(if blank-icon
|
||||
(display "[ ]" port)
|
||||
(emit-tag port 'img
|
||||
(cons 'src blank-icon)
|
||||
(cons 'alt " ")))
|
||||
(write-string "Name " port)
|
||||
(write-string "Last modified " port)
|
||||
(write-string "Size " port)
|
||||
(write-string "Description" port)
|
||||
(emit-tag port 'hr)
|
||||
(if back-icon
|
||||
(emit-tag port 'img
|
||||
(cons 'src back-icon)
|
||||
(cons 'alt "[UP ]"))
|
||||
(display "[UP ]" port))
|
||||
(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 port options)))
|
||||
(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 options)
|
||||
(let ((index-fname (string-append fname "index.html")))
|
||||
(if (file-readable? index-fname)
|
||||
(file-serve-response index-fname file-path req options)
|
||||
(directory-serve-response fname file-path req options))))
|
||||
|
||||
(define (file-serve-and-dir-response fname file-path req options)
|
||||
(file-serve-or-dir-response fname file-path req
|
||||
index-or-directory-serve-response
|
||||
options))
|
||||
|
||||
;;; 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 options)
|
||||
(if (file-not-readable? filename) ; #### double stats are no good
|
||||
(make-error-response (status-code not-found) req)
|
||||
(receive (stripped-filename content-encoding)
|
||||
((file-directory-options-file-name->content-encoding options) filename)
|
||||
(make-response (status-code ok)
|
||||
#f
|
||||
(time)
|
||||
((file-directory-options-file-name->content-type options)
|
||||
stripped-filename)
|
||||
(append (if content-encoding
|
||||
(list (cons 'content-encoding content-encoding))
|
||||
'())
|
||||
(list
|
||||
(cons 'last-modified
|
||||
(rfc822-time->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 (default-file-name->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 ".css") "text/css")
|
||||
((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 (default-file-name->content-encoding fname)
|
||||
(cond
|
||||
((let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
((string-ci=? ext ".Z") "x-compress")
|
||||
((string-ci=? ext ".gz") "x-gzip")
|
||||
(else #f)))
|
||||
=> (lambda (encoding)
|
||||
(values (file-name-sans-extension fname) encoding)))
|
||||
(else (values fname #f))))
|
||||
|
||||
|
|
@ -1,99 +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
|
||||
(let ((body (string-trim (get-header (request-headers req) 'host))))
|
||||
(or (string-ci=? hostname body)
|
||||
(string-prefix-ci? (string-append hostname ":") body))))
|
||||
handler default-handler))
|
||||
|
||||
(define (get-header headers tag)
|
||||
(cond
|
||||
((assq tag headers) => cdr)
|
||||
(else
|
||||
(http-error (status-code bad-request) #f
|
||||
(string-append "Request did not contain "
|
||||
(symbol->string tag)
|
||||
" header")))))
|
||||
|
||||
;; selects handler according to path-prefix
|
||||
;; if path-prefix matches, handler is called without the path-prefix
|
||||
(define (make-path-prefix-handler path-prefix handler default-handler)
|
||||
(lambda (path req)
|
||||
(if (and (pair? path) (string=? path-prefix (car path)))
|
||||
(handler (cdr path) req)
|
||||
(default-handler path req))))
|
||||
|
||||
;;; (alist-path-dispatcher handler-alist default-handler) -> handler
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This function creates a table-driven request handler that dispatches off
|
||||
;;; of the car of the request path. The handler uses the car to index into
|
||||
;;; a request handler alist. If it finds a hit, it recurses using the table's
|
||||
;;; request handler. If no hits, it handles the path with a default handler.
|
||||
;;; An alist handler is passed the tail of the original path; the
|
||||
;;; default handler gets the entire original path.
|
||||
;;;
|
||||
;;; This procedure is how you say: "If the first element of the URL's
|
||||
;;; path is 'foo', do X; if it's 'bar', do Y; otherwise, do Z."
|
||||
|
||||
(define (alist-path-dispatcher handler-alist default-handler)
|
||||
(fold-right
|
||||
(lambda (handler-pair default-handler)
|
||||
(make-path-prefix-handler
|
||||
(car handler-pair)
|
||||
(cdr handler-pair)
|
||||
default-handler))
|
||||
default-handler
|
||||
handler-alist))
|
||||
|
||||
;;; The null request handler -- handles nothing, sends back an error response.
|
||||
;;; Can be useful as the default in table-driven request handlers.
|
||||
|
||||
(define (null-request-handler path req)
|
||||
(make-error-response (status-code not-found) req))
|
||||
|
|
@ -1,661 +0,0 @@
|
|||
;;; GNU info -> HTML gateway for the SU web server. -*- Scheme -*-
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
|
||||
;;; Copyright (c) 1996 by Mike Sperber.
|
||||
;;; based on code with the same purpose by Gaebe Engelhart
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
|
||||
;;; (info-handler parse-info reference find-icon address) -> handler
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This function creates a request handler that converts GNU info pages
|
||||
;;; on-the-fly. It is highly parameterizable to accomodate a wide
|
||||
;;; range of environments. The parameters specify how to find the
|
||||
;;; source code for the info pages, and how to generate certain
|
||||
;;; elements of the generated HTML output.
|
||||
;;;
|
||||
;;; PARSE-INFO specifies how to parse the URLs that end up in the
|
||||
;;; handler.
|
||||
;;; It can be:
|
||||
;;;
|
||||
;;; * a procedure which is called with the URL as its parameters.
|
||||
;;; It is expected to return with two values, FIND-ENTRY and
|
||||
;;; NODE-NAME. FIND-ENTRY, in turn, can be either a procedure
|
||||
;;; which gets passed the file name of an info node and is
|
||||
;;; supposed to return with an absolute name of same. If it is a
|
||||
;;; list, that list is taken as a list of directories in which to
|
||||
;;; search for the info files. NODE-NAME is supposed to be the
|
||||
;;; name of an info node of the form (<file>)<node>, extracted
|
||||
;;; from the URL.
|
||||
;;;
|
||||
;;; * a list, in which case that is taken as a list of
|
||||
;;; directories in which to search for the info files. The node
|
||||
;;; name of a node is extracted from the URL by just taking the
|
||||
;;; search component of the URL.
|
||||
;;;
|
||||
;;; * #f in which case the info path is taken from the environment
|
||||
;;; variable INFOPATH, and the node name extraction works as
|
||||
;;; above.
|
||||
;;;
|
||||
;;; REFERENCE specifies how to generate cross-references to other info
|
||||
;;; nodes. It can be:
|
||||
;;;
|
||||
;;; * a procedure which gets called with the URL of the info page
|
||||
;;; which contains the reference, and the node name of the node
|
||||
;;; to be referenced. The procedure is expected to return the
|
||||
;;; text for a link.
|
||||
;;;
|
||||
;;; * a string, in which case that is to be a prefix to which the
|
||||
;;; node name is simply appended to yield the new link.
|
||||
;;;
|
||||
;;; * #f in which case all references have the form
|
||||
;;; info?<node-name>.
|
||||
;;;
|
||||
;;; FIND-ICON specifies to to find the various icons used to decorate
|
||||
;;; info pages. It can be:
|
||||
;;;
|
||||
;;; * a procedure which gets passed one of the tags in
|
||||
;;; DEFAULT-ICON-ALIST and is supposed to return a link for the
|
||||
;;; appropriate icon (or #f if no icon is to be used)
|
||||
;;;
|
||||
;;; * a string which is taken as a prefix to which one of the
|
||||
;;; appropriate icon name from DEFAULT-ICON-ALIST is appended.
|
||||
;;; (Note that these icon names were stolen from the
|
||||
;;; cern-httpd-3.0 distribution at
|
||||
;;; http://www.w3.org/pub/WWW/Daemon/.)
|
||||
;;;
|
||||
;;; * a list which is taken as an alist of the same format as
|
||||
;;; DEFAULT-ICON-ALIST.
|
||||
;;;
|
||||
;;; * #f in which case no icons are used.
|
||||
;;;
|
||||
;;; ADDRESS a string to be appended at the bottom of all info pages
|
||||
;;;
|
||||
;;; To install a vanilla info handler for a prefix "info?" that looks
|
||||
;;; in the environment variable INFOPATH, just use something like
|
||||
;;; (info-handler #f #f #f "Generated by info-gateway")
|
||||
|
||||
;;; TODO: write a CGI version of this
|
||||
|
||||
(define-condition-type 'info-gateway-error '(error))
|
||||
|
||||
(define info-gateway-error? (condition-predicate 'info-gateway-error))
|
||||
|
||||
(define (info-gateway-error msg . irritants)
|
||||
(apply signal 'info-gateway-error msg irritants))
|
||||
|
||||
(define default-icon-alist
|
||||
'((info . "infodoc.gif")
|
||||
(up . "up.gif")
|
||||
(next . "next.gif")
|
||||
(previous . "prev.gif")
|
||||
(menu . "menu.gif")))
|
||||
|
||||
(define (info-handler parse-info reference find-icon address)
|
||||
(let ((icon-name
|
||||
(cond
|
||||
((procedure? find-icon) find-icon)
|
||||
((string? find-icon)
|
||||
(let ((alist
|
||||
(map (lambda (entry)
|
||||
(cons (car entry)
|
||||
(string-append find-icon (cdr entry))))
|
||||
default-icon-alist)))
|
||||
(lambda (tag)
|
||||
(cond ((assq tag alist) => cdr)
|
||||
(else #f)))))
|
||||
((list? find-icon)
|
||||
(lambda (tag)
|
||||
(cond ((assq tag find-icon) => cdr)
|
||||
(else #f))))
|
||||
(else (lambda (tag) #f))))
|
||||
(parse-info-url
|
||||
(cond
|
||||
((procedure? parse-info) parse-info)
|
||||
((list? parse-info) ; it's an info path
|
||||
(lambda (url)
|
||||
(values parse-info
|
||||
(unescape-uri (http-url-search url)))))
|
||||
(else
|
||||
(let ((info-path
|
||||
((infix-splitter ":")
|
||||
(or (getenv "INFOPATH")
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"~%Warning: environment variable INFOPATH is unset.~%")
|
||||
"")))))
|
||||
(lambda (url)
|
||||
(values info-path
|
||||
(unescape-uri (http-url-search url))))))))
|
||||
(make-reference
|
||||
(cond
|
||||
((procedure? reference) reference)
|
||||
((string? reference)
|
||||
(lambda (url node-name)
|
||||
(string-append reference node-name)))
|
||||
(else
|
||||
(lambda (url node-name)
|
||||
(string-append "info?" node-name))))))
|
||||
|
||||
(lambda (path req)
|
||||
(let ((request-method (request-method req)))
|
||||
(cond
|
||||
((string=? request-method "GET")
|
||||
(with-fatal-error-handler
|
||||
(lambda (c decline)
|
||||
(cond
|
||||
((info-gateway-error? c)
|
||||
(apply http-error (status-code bad-gateway) req
|
||||
(condition-stuff c)))
|
||||
((http-error? c)
|
||||
(apply http-error (car (condition-stuff c)) req
|
||||
(cddr (condition-stuff c))))
|
||||
(else
|
||||
(decline))))
|
||||
|
||||
(make-response
|
||||
(status-code ok)
|
||||
#f
|
||||
(time)
|
||||
"text/html"
|
||||
'()
|
||||
(make-writer-body
|
||||
(lambda (out options)
|
||||
|
||||
(receive (find-entry node-name) (parse-info-url (request-url req))
|
||||
(display-node node-name
|
||||
(file-finder find-entry)
|
||||
(referencer make-reference (request-url req) out)
|
||||
icon-name
|
||||
out))
|
||||
(with-tag out address ()
|
||||
(write-string address out)))))))
|
||||
|
||||
(else
|
||||
(make-error-response (status-code method-not-allowed) req
|
||||
request-method)))))))
|
||||
|
||||
(define split-header-line
|
||||
(let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)")))
|
||||
(split-field (infix-splitter (make-regexp ": *"))))
|
||||
(lambda (l)
|
||||
(let ((fields (map split-field (split l))))
|
||||
|
||||
(define (search-field regexp)
|
||||
(cond
|
||||
((find (lambda (field)
|
||||
(string-match regexp (car field)))
|
||||
fields)
|
||||
=> cadr)
|
||||
(else #f)))
|
||||
|
||||
(values (search-field "[F|f]ile")
|
||||
(search-field "[N|n]ode")
|
||||
(search-field "[U|u]p")
|
||||
(search-field "[P|p]rev(ious)?")
|
||||
(search-field "[N|n]ext"))))))
|
||||
|
||||
(define (replace-if-empty-string s v)
|
||||
(if (zero? (string-length s))
|
||||
v
|
||||
s))
|
||||
|
||||
(define (string-newline->space s)
|
||||
(string-map (lambda (c)
|
||||
(if (char=? c #\newline)
|
||||
#\space
|
||||
c))
|
||||
s))
|
||||
|
||||
(define (parse-node-name node-name)
|
||||
(cond
|
||||
((string-match "^\\((.*)\\)(.*)$" (string-newline->space node-name))
|
||||
=> (lambda (match)
|
||||
(values
|
||||
(replace-if-empty-string (match:substring match 1) #f)
|
||||
(replace-if-empty-string (match:substring match 2) "Top"))))
|
||||
(else (values #f (string-newline->space node-name)))))
|
||||
|
||||
|
||||
(define (unparse-node-name file node)
|
||||
(let* ((ext (file-name-extension file))
|
||||
(file (if (string=? ext ".info")
|
||||
(file-name-sans-extension file)
|
||||
file)))
|
||||
(receive (file node) (if (and (string=? "dir" file)
|
||||
(not (string=? "" node))
|
||||
(not (string=? "Top" node)))
|
||||
(values node "Top")
|
||||
(values file node))
|
||||
(string-append "(" file ")" node))))
|
||||
|
||||
(define (display-icon file alt out)
|
||||
(emit-tag out 'img
|
||||
(cons 'src file)
|
||||
(cons 'alt alt)
|
||||
(cons 'align "bottom")))
|
||||
|
||||
(define (referencer make-reference old-entry out)
|
||||
(lambda (file node-name label . maybe-icon)
|
||||
(receive (node-file node) (parse-node-name node-name)
|
||||
(let ((file (or node-file file)))
|
||||
(with-tag out a ((href (make-reference
|
||||
old-entry
|
||||
(escape-uri (unparse-node-name file node)))))
|
||||
(if (and (not (null? maybe-icon))
|
||||
(car maybe-icon))
|
||||
(display-icon (car maybe-icon) (cadr maybe-icon) out))
|
||||
(emit-text label out))))))
|
||||
|
||||
(define node-prologue (ascii->char 31))
|
||||
(define node-epilogue-regexp
|
||||
(make-regexp
|
||||
(string-append (regexp-quote (string node-prologue))
|
||||
"|"
|
||||
(regexp-quote (string (ascii->char 12))))))
|
||||
|
||||
(define (string-starts-with-char? s c)
|
||||
(and (not (zero? (string-length s)))
|
||||
(char=? c (string-ref s 0))))
|
||||
|
||||
(define (node-prologue? s)
|
||||
(string-starts-with-char? s node-prologue))
|
||||
(define (node-epilogue? s)
|
||||
(regexp-exec node-epilogue-regexp s))
|
||||
|
||||
;; Document title
|
||||
|
||||
(define (display-title file node up previous next
|
||||
display-reference icon-name out)
|
||||
|
||||
(define (maybe-display-header header icon alt)
|
||||
(if header
|
||||
(begin
|
||||
(newline out)
|
||||
(with-tag out b ()
|
||||
(display-reference file header header icon alt)))))
|
||||
|
||||
(emit-title out (string-append "Info Node: "
|
||||
(unparse-node-name file node)))
|
||||
(with-tag out h1 ()
|
||||
(emit-tag out 'img
|
||||
(cons 'src (icon-name 'info))
|
||||
(cons 'alt "Info Node")
|
||||
(cons 'align 'bottom))
|
||||
(write-string (unparse-node-name file node) out))
|
||||
(emit-tag out 'hr)
|
||||
(maybe-display-header next (icon-name 'next) "[Next]")
|
||||
(maybe-display-header previous (icon-name 'previous) "[Previous]")
|
||||
(maybe-display-header up (icon-name 'up) "[Up]")
|
||||
|
||||
(if (or next previous up)
|
||||
(emit-tag out 'hr)))
|
||||
|
||||
;; Text
|
||||
|
||||
|
||||
;; Dealing with cross references
|
||||
;; info sucks
|
||||
|
||||
(define xref-marker-regexp (make-regexp "\\*[Nn]ote([ \n]|$)"))
|
||||
(define xref-regexp (make-regexp "\\*[Nn]ote *([^:]*): *([^\t\n,.;:?!]*)"))
|
||||
|
||||
(define max-xref-lines 3)
|
||||
|
||||
(define complete-line
|
||||
(let ((split-xref-markers (field-splitter xref-marker-regexp))
|
||||
(split-xrefs (field-splitter xref-regexp))
|
||||
(cr (string #\newline)))
|
||||
(lambda (line port)
|
||||
(let loop ((line line) (count max-xref-lines))
|
||||
(let ((xref-markers (split-xref-markers line))
|
||||
(xrefs (split-xrefs line)))
|
||||
(if (= (length xref-markers) (length xrefs))
|
||||
line
|
||||
(if (zero? count)
|
||||
(info-gateway-error "invalid cross reference")
|
||||
(let ((new-line (read-line port)))
|
||||
(if (eof-object? new-line)
|
||||
(info-gateway-error
|
||||
"unexpected end of info file inside cross reference"))
|
||||
(loop (string-append line cr new-line) (- count 1))))))))))
|
||||
|
||||
|
||||
(define (display-xref xref file display-reference out)
|
||||
(let* ((match (regexp-exec xref-regexp xref))
|
||||
(note (match:substring match 1))
|
||||
(node-name (match:substring match 2))
|
||||
(node-name (if (string=? "" node-name) note node-name))
|
||||
(node-name (substring node-name
|
||||
(string-skip node-name char-set:whitespace)
|
||||
(string-length node-name))))
|
||||
(emit-text "See " out)
|
||||
(display-reference file node-name note)))
|
||||
|
||||
(define display-text
|
||||
(let ((split-xrefs (infix-splitter xref-regexp #f 'split)))
|
||||
(lambda (line port file display-reference out)
|
||||
(let* ((line (complete-line line port))
|
||||
(components (split-xrefs line)))
|
||||
;; in components, every 2nd element is a cross reference
|
||||
;; also, it always has odd length or length zero
|
||||
(if (not (null? components))
|
||||
(let loop ((components components))
|
||||
(emit-text (car components) out)
|
||||
(if (not (null? (cdr components)))
|
||||
(begin
|
||||
(display-xref (cadr components) file display-reference out)
|
||||
(loop (cddr components))))))
|
||||
(newline out)))))
|
||||
|
||||
;; Menus
|
||||
|
||||
(define menu-regexp (make-regexp "^\\* +Menu:"))
|
||||
(define menu-item-regexp (make-regexp "^\\* +"))
|
||||
|
||||
(define (char-splitter c)
|
||||
(lambda (s)
|
||||
(cond ((string-index s c)
|
||||
=> (lambda (i)
|
||||
(values (substring s 0 i)
|
||||
(substring s (+ 1 i) (string-length s)))))
|
||||
(else (values s "")))))
|
||||
|
||||
(define colon-split (char-splitter #\:))
|
||||
|
||||
(define (display-menu-item-header line port file display-reference icon-name out)
|
||||
(let ((menu-line-split (infix-splitter menu-item-regexp)))
|
||||
(receive (note rest) (colon-split (cadr (menu-line-split line)))
|
||||
(receive (node-name text)
|
||||
(cond
|
||||
((string-match ": *(.*)" rest)
|
||||
=> (lambda (match)
|
||||
(values note (match:substring match 1))))
|
||||
((string-match "^ *([^.]*)\\.? *(.*)" rest)
|
||||
=> (lambda (match)
|
||||
(values (match:substring match 1)
|
||||
(match:substring match 2))))
|
||||
(else
|
||||
(info-gateway-error "invalid menu item")))
|
||||
(emit-tag out 'dt)
|
||||
(display-reference file node-name note (icon-name 'menu) "*")
|
||||
(newline out)
|
||||
(if (and (not (string=? "" text))
|
||||
(not (string=? "." text)))
|
||||
(begin
|
||||
(emit-tag out 'dd)
|
||||
(display-text text port file display-reference out)))))))
|
||||
|
||||
(define (display-menu line port file display-reference icon-name out)
|
||||
(emit-close-tag out 'pre)
|
||||
|
||||
(with-tag out dl ()
|
||||
(let loop ((line line))
|
||||
(if (eof-object? line)
|
||||
(info-gateway-error "unexpected end of info file"))
|
||||
|
||||
(display-menu-item-header line port file display-reference icon-name out)
|
||||
|
||||
(let finish-item-loop ()
|
||||
(if (eof-object? line)
|
||||
(info-gateway-error "unexpected end of info file"))
|
||||
|
||||
(let ((line (read-line port)))
|
||||
(cond
|
||||
((or (eof-object? line)
|
||||
(node-epilogue? line)
|
||||
(string=? "" line))
|
||||
(emit-tag out 'pre)
|
||||
(dispatch-line line port file display-reference icon-name out))
|
||||
((regexp-exec menu-item-regexp line)
|
||||
(loop line))
|
||||
(else
|
||||
(display-text line port file display-reference out)
|
||||
(finish-item-loop))))))))
|
||||
|
||||
;; Central dispatch
|
||||
|
||||
(define (dispatch-line line port file display-reference icon-name out)
|
||||
(cond
|
||||
((or (eof-object? line) (node-epilogue? line)) #f)
|
||||
((string=? "" line) (emit-p out) #t)
|
||||
((regexp-exec menu-regexp line) #t) ;; this should probably be expanded
|
||||
((regexp-exec menu-item-regexp line)
|
||||
(display-menu line port file display-reference icon-name out))
|
||||
(else
|
||||
(display-text line port file display-reference out) #t)))
|
||||
|
||||
(define (display-body port file display-reference icon-name out)
|
||||
(let loop ()
|
||||
(let ((line (read-line port)))
|
||||
(if (dispatch-line line port file display-reference icon-name out)
|
||||
(loop)))))
|
||||
|
||||
(define (display-node node-name find-file display-reference icon-name out)
|
||||
(receive (file node) (parse-node-name node-name)
|
||||
(receive (port file-header node-header up-header prev-header next-header)
|
||||
(find-node file node find-file)
|
||||
|
||||
(with-tag out html ()
|
||||
(with-tag out head ()
|
||||
(display-title file node-header up-header
|
||||
prev-header next-header
|
||||
display-reference icon-name
|
||||
out))
|
||||
(with-tag out body ()
|
||||
(with-tag out pre ()
|
||||
(display-body port file display-reference icon-name out))))
|
||||
|
||||
(close-input-port port))))
|
||||
|
||||
;; Finding nodes
|
||||
|
||||
(define (ensure-node-prologue port msg)
|
||||
(let ((line (read-line port)))
|
||||
(if (or (eof-object? line)
|
||||
(not (node-prologue line)))
|
||||
(info-gateway-error "invalid info file" msg))))
|
||||
|
||||
(define (ensure-regexp-line port regexp msg)
|
||||
(let ((line (read-line port)))
|
||||
(if (or (eof-object? line)
|
||||
(not (string-match regexp line)))
|
||||
(info-gateway-error "invalid info file" msg))))
|
||||
|
||||
(define (ensure-tag-table-node port)
|
||||
(ensure-regexp-line port "^Tag Table:" "no tag table"))
|
||||
(define (ensure-indirect-tag-table-header port)
|
||||
(ensure-regexp-line port "^\\(Indirect\\)" "no indirect tag"))
|
||||
|
||||
(define split-indirection (infix-splitter (make-regexp " *: *")))
|
||||
(define (parse-indirection line)
|
||||
(let ((l (split-indirection line)))
|
||||
(if (null? (cdr l))
|
||||
(info-gateway-error "invalid indirection entry in info file")
|
||||
(let ((file (car l))
|
||||
(seek-pos (string->number (cadr l))))
|
||||
(if (not seek-pos)
|
||||
(info-gateway-error "invalid indirection entry in info file"))
|
||||
(cons file seek-pos)))))
|
||||
|
||||
(define (read-indirection-table port)
|
||||
(let loop ((table '()))
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
(info-gateway-error "invalid info file"))
|
||||
(if (node-epilogue? line)
|
||||
(reverse table)
|
||||
(loop (cons (parse-indirection line) table))))))
|
||||
|
||||
(define tag-seek-separator (ascii->char 127))
|
||||
|
||||
(define parse-tag
|
||||
(let ((split (infix-splitter (make-regexp ", *")))
|
||||
(split-field (infix-splitter ": "))
|
||||
(split-node-info
|
||||
(infix-splitter (string tag-seek-separator))))
|
||||
|
||||
(define (barf)
|
||||
(info-gateway-error "invalid tag entry in info file"))
|
||||
|
||||
(lambda (line)
|
||||
(let* ((fields (map split-field (split line)))
|
||||
(file (cond
|
||||
((assoc "File" fields)
|
||||
=> (lambda (p)
|
||||
(if (null? (cdr p)) (barf))
|
||||
(cadr p)))
|
||||
(else #f))))
|
||||
(cond
|
||||
((assoc "Node" fields)
|
||||
=> (lambda (p)
|
||||
(if (null? (cdr p)) (barf))
|
||||
(let ((s (split-node-info (cadr p))))
|
||||
(if (null? (cdr p)) (barf))
|
||||
(let* ((node (car s))
|
||||
(seek (string->number (cadr s))))
|
||||
(if (not seek) (barf))
|
||||
(values node file seek)))))
|
||||
(else (barf)))))))
|
||||
|
||||
(define (find-tag node port)
|
||||
(let loop ()
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
(info-gateway-error "invalid info file"))
|
||||
(if (regexp-exec node-epilogue-regexp line)
|
||||
(http-error (status-code not-found) #f "node not found"))
|
||||
(receive (entry-node file seek) (parse-tag line)
|
||||
(if (string=? node entry-node)
|
||||
(cons file seek)
|
||||
(loop))))))
|
||||
|
||||
(define (find-indirection-entry seek-pos indirection-table)
|
||||
(let loop ((table indirection-table))
|
||||
(if (null? table)
|
||||
(http-error (status-code not-found) #f "node not found"))
|
||||
(let* ((entry (car table))
|
||||
(pos (cdr entry)))
|
||||
(if (and (>= seek-pos pos)
|
||||
(or (null? (cdr table))
|
||||
(let* ((next-entry (cadr table))
|
||||
(next-pos (cdr next-entry)))
|
||||
(< seek-pos next-pos))))
|
||||
entry
|
||||
(loop (cdr table))))))
|
||||
|
||||
(define (file-finder with)
|
||||
(cond ((procedure? with) with)
|
||||
((list? with)
|
||||
(lambda (file)
|
||||
(find-info-file file with)))))
|
||||
|
||||
(define (find-node-port-with-tag-entry node tag-entry ? find-file)
|
||||
(let* ((port (if (input-port? ?) ? #f))
|
||||
(indirection-table (if port #f ?))
|
||||
(seek-pos (cdr tag-entry))
|
||||
(indirection-entry
|
||||
(and indirection-table
|
||||
(find-indirection-entry seek-pos indirection-table)))
|
||||
(seek-pos (if indirection-entry
|
||||
(- seek-pos (cdr indirection-entry))
|
||||
seek-pos))
|
||||
;; that's what the documentation says ...
|
||||
(seek-pos (if (>= seek-pos 1000)
|
||||
(- seek-pos 1000)
|
||||
0))
|
||||
(file (or (car tag-entry)
|
||||
(and indirection-entry
|
||||
(car indirection-entry))))
|
||||
(port (if file
|
||||
(begin
|
||||
(if port (close-input-port port))
|
||||
(open-input-file (find-file file)))
|
||||
port)))
|
||||
(seek port seek-pos)
|
||||
port))
|
||||
|
||||
(define (find-node file node find-file)
|
||||
(if (not file)
|
||||
(http-error (status-code not-found) #f
|
||||
"no file in info node specification"))
|
||||
|
||||
(let* ((fname (find-file file))
|
||||
(port (open-input-file fname)))
|
||||
(let loop ((port port))
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
(http-error (status-code not-found) #f "info node not found"))
|
||||
(if (node-prologue? line)
|
||||
(let ((header (read-line port)))
|
||||
(if (eof-object? header)
|
||||
(info-gateway-error "invalid info file"))
|
||||
(cond
|
||||
|
||||
((string-match "^Indirect:" header)
|
||||
(let ((indirection-table
|
||||
(read-indirection-table port)))
|
||||
(ensure-tag-table-node port)
|
||||
(ensure-indirect-tag-table-header port)
|
||||
(let ((tag-entry (find-tag node port)))
|
||||
(close-input-port port)
|
||||
(loop (find-node-port-with-tag-entry
|
||||
node tag-entry indirection-table find-file)))))
|
||||
|
||||
((string-match "^Tag Table:" header)
|
||||
(let ((tag-entry (find-tag node port)))
|
||||
(loop (find-node-port-with-tag-entry
|
||||
node tag-entry port find-file))))
|
||||
|
||||
((string-match "^File:" header)
|
||||
(receive
|
||||
(file-header node-header up-header prev-header next-header)
|
||||
(split-header-line header)
|
||||
(if (string=? node-header node)
|
||||
(values port
|
||||
file-header node-header
|
||||
up-header prev-header next-header)
|
||||
(loop port))))
|
||||
(else (loop port))))
|
||||
(loop port))))))
|
||||
|
||||
;; Finding files
|
||||
|
||||
(define (info-file-alternative-names file)
|
||||
(receive (dir base ext) (parse-file-name file)
|
||||
(let* ((base
|
||||
(cond ((string-match "(.*)-info$" base)
|
||||
=> (lambda (match)
|
||||
(match:substring match 1)))
|
||||
(else base)))
|
||||
(base-ci (string-map char-downcase base))
|
||||
(alts-1 (if (string=? base base-ci)
|
||||
(list base)
|
||||
(list base base-ci)))
|
||||
(alts (append alts-1
|
||||
(map (lambda (base)
|
||||
(string-append base ".info"))
|
||||
alts-1)))
|
||||
(alts (append alts
|
||||
(map (lambda (base)
|
||||
(string-append base "-info"))
|
||||
alts-1)))
|
||||
(alts (map (lambda (f) (string-append dir f)) alts))
|
||||
(alts (cons file alts)))
|
||||
alts)))
|
||||
|
||||
(define (find-info-file file info-path)
|
||||
(let ((alts (info-file-alternative-names file)))
|
||||
(let path-loop ((path info-path))
|
||||
(if (null? path)
|
||||
(http-error (status-code not-found) #f "info file not found"))
|
||||
(let alt-loop ((alts alts))
|
||||
(if (null? alts)
|
||||
(path-loop (cdr path))
|
||||
(let ((try (string-append (file-name-as-directory (car path))
|
||||
(car alts))))
|
||||
(if (file-exists? try)
|
||||
try
|
||||
(alt-loop (cdr alts)))))))))
|
||||
|
|
@ -1,196 +0,0 @@
|
|||
;;; logging.scm
|
||||
;;; logging functionality for web server
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
|
||||
;;; Copyright (c) 2002 by Martin Gasbichler.
|
||||
;;; Copyright (c) 2002 by Andreas Bernauer.
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
(define do-nothing-proc (lambda a #f))
|
||||
|
||||
(define-record-type logging :logging
|
||||
(really-make-logging log-port log-proc
|
||||
syslog? syslog-proc
|
||||
dns-lookup?)
|
||||
logging?
|
||||
;; port to perform CLF-logging
|
||||
(log-port logging-log-port set-logging-log-port!)
|
||||
;; proc to run for CLF-logging (req status-code)
|
||||
(log-proc logging-log-proc set-logging-log-proc!)
|
||||
;; do syslogging?
|
||||
(syslog? logging-syslog? set-logging-syslog?!)
|
||||
;; proc to run for syslog (level fmt . args)
|
||||
(syslog-proc logging-syslog-proc set-logging-syslog-proc!)
|
||||
;; perform dns lookups?
|
||||
(dns-lookup? logging-dns-lookup? set-logging-dns-lookup?!))
|
||||
|
||||
(define (make-logging)
|
||||
(really-make-logging #f
|
||||
do-nothing-proc
|
||||
#f
|
||||
do-nothing-proc
|
||||
#f))
|
||||
|
||||
(define logging (make-preserved-thread-fluid #f))
|
||||
|
||||
(define (make-fluid-selector selector)
|
||||
(lambda () (selector (thread-fluid logging))))
|
||||
|
||||
(define (make-fluid-setter setter)
|
||||
(lambda (value)
|
||||
(setter (thread-fluid logging) value)))
|
||||
|
||||
(define logging-http-log-proc (make-fluid-selector logging-log-proc))
|
||||
(define logging-http-syslog-proc (make-fluid-selector logging-syslog-proc))
|
||||
(define logging-http-syslog? (make-fluid-selector logging-syslog?))
|
||||
(define logging-http-log-port (make-fluid-selector logging-log-port))
|
||||
(define logging-dns-lookup? (make-fluid-selector logging-dns-lookup?))
|
||||
|
||||
(define set-logging-http-log-proc (make-fluid-setter set-logging-log-proc!))
|
||||
(define set-logging-http-syslog-proc (make-fluid-setter set-logging-syslog-proc!))
|
||||
(define set-logging-http-syslog? (make-fluid-setter set-logging-syslog?!))
|
||||
(define set-logging-http-log-port (make-fluid-setter set-logging-log-port!))
|
||||
(define set-logging-dns-lookup? (make-fluid-setter set-logging-dns-lookup?!))
|
||||
|
||||
(define http-syslog
|
||||
(lambda a
|
||||
(apply (logging-http-syslog-proc) a)))
|
||||
|
||||
(define http-log
|
||||
(lambda a
|
||||
(apply (logging-http-log-proc) a)))
|
||||
|
||||
(define (http-syslog?)
|
||||
(logging-http-syslog?))
|
||||
|
||||
(define (init-http-log! options)
|
||||
;; syslog has to be initialized before CLF-logging
|
||||
;; because the latter may generate syslog-messages
|
||||
(init-http-syslog! (httpd-options-syslog? options))
|
||||
(init-http-port-log! (httpd-options-log-file 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! log-file)
|
||||
(let ((logport
|
||||
(cond
|
||||
((string? log-file) ; try to open log-file for appending (output)
|
||||
(open-log-file log-file))
|
||||
((output-port? log-file) ; we were given an output port, so let's use it
|
||||
log-file)
|
||||
((eq? log-file #f) ; no logging demanded
|
||||
#f)
|
||||
; unexpected value of log-file;
|
||||
(else
|
||||
(http-syslog
|
||||
(syslog-level warning)
|
||||
"[httpd] Warning: Log-File was not specified correctly (given: ~S).~% No CLF logging."
|
||||
log-file)
|
||||
(make-null-output-port)))))
|
||||
|
||||
(if log-file ; if logging was specified, set up the logger
|
||||
(let ((http-log-lock (make-lock)))
|
||||
(set-logging-http-log-port logport)
|
||||
(if (string? log-file)
|
||||
(spawn (make-log-file-rotator log-file 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 #f)))
|
||||
|
||||
;; does the log-file rotation on signal USR1
|
||||
(define (make-log-file-rotator log-file 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-log-file log-file))))))))
|
||||
|
||||
(define (open-log-file log-file)
|
||||
(with-errno-handler*
|
||||
(lambda (errno packet)
|
||||
(http-syslog (syslog-level warning)
|
||||
"[httpd] Warning: An error occurred while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
|
||||
log-file
|
||||
(car packet))
|
||||
(make-null-output-port))
|
||||
(lambda ()
|
||||
(open-output-file log-file
|
||||
(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 occurred while resolving IP ~A: ~A"
|
||||
remote-ip condition)
|
||||
remote-ip)
|
||||
(lambda ()
|
||||
(dns-lookup-ip remote-ip)))
|
||||
remote-ip)
|
||||
remote-ip))
|
||||
|
|
@ -1,131 +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
|
||||
fqdn
|
||||
reported-port
|
||||
request-handler
|
||||
server-admin
|
||||
simultaneous-requests
|
||||
log-file
|
||||
syslog?
|
||||
resolve-ips?
|
||||
post-bind-thunk)
|
||||
httpd-options?
|
||||
(port httpd-options-port
|
||||
set-httpd-options-port!)
|
||||
(root-directory httpd-options-root-directory
|
||||
set-httpd-options-root-directory!)
|
||||
(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!)
|
||||
(log-file httpd-options-log-file set-httpd-options-log-file!)
|
||||
(syslog? httpd-options-syslog? set-httpd-options-syslog?!)
|
||||
(resolve-ips? httpd-options-resolve-ips? set-httpd-options-resolve-ips?!)
|
||||
(post-bind-thunk httpd-options-post-bind-thunk set-httpd-options-post-bind-thunk!))
|
||||
|
||||
; default httpd-options generation
|
||||
(define (make-default-httpd-options)
|
||||
(really-make-httpd-options 80 ; port
|
||||
"/" ; root-directory
|
||||
#f ; fqdn
|
||||
#f ; reported-port
|
||||
#f ; request-handler
|
||||
#f ; server-admin
|
||||
#f ; simultaneous-requests
|
||||
#f
|
||||
; string: filename of log-file (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 log-files?
|
||||
#f)) ; post-bind-thunk
|
||||
|
||||
; 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-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-log-file! new-options (httpd-options-log-file options))
|
||||
(set-httpd-options-syslog?! new-options (httpd-options-syslog? options))
|
||||
(set-httpd-options-resolve-ips?! new-options (httpd-options-resolve-ips? options))
|
||||
(set-httpd-options-post-bind-thunk! new-options
|
||||
(httpd-options-post-bind-thunk 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-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-log-file
|
||||
(make-httpd-options-transformer set-httpd-options-log-file!))
|
||||
(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 with-post-bind-thunk
|
||||
(make-httpd-options-transformer set-httpd-options-post-bind-thunk!))
|
||||
|
||||
(define (make-httpd-options . stuff)
|
||||
(let loop ((options (make-default-httpd-options))
|
||||
(stuff stuff))
|
||||
(if (null? stuff)
|
||||
options
|
||||
(let* ((transformer (car stuff))
|
||||
(value (cadr stuff)))
|
||||
(loop (transformer value options)
|
||||
(cddr stuff))))))
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
;;;; HTTP request
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
;;; Copyright (c) 1996 by Olin Shivers.
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
;;;; This code defines the http REQUEST data structure
|
||||
|
||||
(define-record-type request :request
|
||||
(make-request method uri url version headers socket)
|
||||
request?
|
||||
(method request-method) ; A string such as "GET", "PUT", etc.
|
||||
(uri request-uri) ; The escaped URI string as read from request line.
|
||||
(url request-url) ; An http URL record (see url.scm).
|
||||
(version request-version) ; A (major . minor) integer pair.
|
||||
(headers request-headers) ; An rfc822 header alist (see rfc822.scm).
|
||||
(socket request-socket)) ; The socket connected to the client.
|
||||
|
||||
(define-record-discloser :request
|
||||
(lambda (req)
|
||||
(list 'request
|
||||
(request-method req)
|
||||
(request-uri req)
|
||||
(request-url req)
|
||||
(request-version req)
|
||||
(request-headers req)
|
||||
(request-socket req))))
|
||||
;;; A http protocol version is an integer pair: (major . minor).
|
||||
|
||||
(define (version< v1 v2)
|
||||
(or (< (car v1) (car v2))
|
||||
(and (= (car v1) (car v2))
|
||||
(< (cdr v1) (cdr v2)))))
|
||||
|
||||
(define (version<= v1 v2) (not (version< v2 v1)))
|
||||
|
||||
(define (v0.9-request? req)
|
||||
(version<= (request-version req) '(0 . 9)))
|
||||
|
||||
|
||||
(define (version->string v)
|
||||
(string-append "HTTP/"
|
||||
(number->string (car v))
|
||||
"."
|
||||
(number->string (cdr v))))
|
||||
|
||||
|
|
@ -1,281 +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) ;;HTTP status code
|
||||
(message response-message);;reason phrase: textual description of
|
||||
;;status-code, or #f (-> server sends
|
||||
;;default reason phrase)
|
||||
(seconds response-seconds);;time the content was created
|
||||
(mime response-mime);;string indicating the MIME type of the response
|
||||
(extras response-extras);;assoc list with extra headers to be
|
||||
;;added to the response; its elements are
|
||||
;;pairs, each of which consists of a symbol
|
||||
;;representing the field name and a string
|
||||
;;representing the field value.
|
||||
(body response-body));; message-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-input-response :http-input-response
|
||||
(make-input-response body-maker)
|
||||
input-response?
|
||||
(body-maker input-response-body-maker))
|
||||
|
||||
(define-record-type http-writer-body :http-writer-body
|
||||
(make-writer-body proc)
|
||||
writer-body?
|
||||
(proc writer-body-proc))
|
||||
|
||||
(define-record-type http-reader-writer-body :http-reader-writer-body
|
||||
(make-reader-writer-body proc)
|
||||
reader-writer-body?
|
||||
(proc reader-writer-body-proc))
|
||||
|
||||
(define-record-type http-redirect-body :http-redirect-body
|
||||
(make-redirect-body location)
|
||||
redirect-body?
|
||||
(location redirect-body-location))
|
||||
|
||||
(define (display-http-body body iport oport options)
|
||||
(cond
|
||||
((writer-body? body)
|
||||
((writer-body-proc body) oport options))
|
||||
((reader-writer-body? body)
|
||||
((reader-writer-body-proc body) iport oport options))))
|
||||
|
||||
(define-finite-type status-code :http-status-code
|
||||
(number message)
|
||||
status-code?
|
||||
status-codes
|
||||
status-code-name
|
||||
status-code-index
|
||||
(number status-code-number)
|
||||
(message status-code-message)
|
||||
(
|
||||
(ok 200 "OK")
|
||||
(created 201 "Created")
|
||||
(accepted 202 "Accepted")
|
||||
(prov-info 203 "Provisional Information")
|
||||
(no-content 204 "No Content")
|
||||
|
||||
(mult-choice 300 "Multiple Choices")
|
||||
(moved-perm 301 "Moved Permanently")
|
||||
(moved-temp 302 "Moved Temporarily")
|
||||
(method 303 "Method (obsolete)")
|
||||
(not-mod 304 "Not Modified")
|
||||
|
||||
(bad-request 400 "Bad Request")
|
||||
(unauthorized 401 "Unauthorized")
|
||||
(payment-req 402 "Payment Required")
|
||||
(forbidden 403 "Forbidden")
|
||||
(not-found 404 "Not Found")
|
||||
(method-not-allowed 405 "Method Not Allowed")
|
||||
(none-acceptable 406 "None Acceptable")
|
||||
(proxy-auth-required 407 "Proxy Authentication Required")
|
||||
(timeout 408 "Request Timeout")
|
||||
(conflict 409 "Conflict")
|
||||
(gone 410 "Gone")
|
||||
|
||||
(internal-error 500 "Internal Server Error")
|
||||
(not-implemented 501 "Not Implemented")
|
||||
(bad-gateway 502 "Bad Gateway")
|
||||
(service-unavailable 503 "Service Unavailable")
|
||||
(gateway-timeout 504 "Gateway Timeout")
|
||||
|
||||
(redirect -301 "Internal redirect")))
|
||||
|
||||
(define (name->status-code name)
|
||||
(if (not (symbol? name))
|
||||
(call-error name->status-code (list name))
|
||||
(let loop ((i 0))
|
||||
(cond ((= i (vector-length status-codes))
|
||||
#f)
|
||||
((eq? name
|
||||
(status-code-name (vector-ref status-codes i)))
|
||||
(vector-ref status-codes i))
|
||||
(else
|
||||
(loop (+ i 1)))))))
|
||||
|
||||
(define (number->status-code number)
|
||||
(if (not (number? number))
|
||||
(call-error number->status-code (list number))
|
||||
(let loop ((i 0))
|
||||
(cond ((= i (vector-length status-codes))
|
||||
#f)
|
||||
((= number
|
||||
(status-code-number (vector-ref status-codes i)))
|
||||
(vector-ref status-codes i))
|
||||
(else
|
||||
(loop (+ i 1)))))))
|
||||
|
||||
;;; (make-error-response status-code req [message . extras])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;
|
||||
;;; As a special case, request REQ is allowed to be #f, meaning we haven't
|
||||
;;; even had a chance to parse and construct the request. This is only used
|
||||
;;; for 400 BAD-REQUEST error report.
|
||||
|
||||
(define (make-error-response code req . args)
|
||||
(let* ((message (and (pair? args) (car args)))
|
||||
(extras (if (pair? args) (cdr args) '()))
|
||||
|
||||
(generic-title (lambda (port)
|
||||
(title-html port
|
||||
(status-code-message code))))
|
||||
(send-message (lambda (port)
|
||||
(if message
|
||||
(format port "<BR>~%Further Information: ~A<BR>~%" message))))
|
||||
(close-html (lambda (port)
|
||||
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
|
||||
(write-string "</BODY>\n" port)))
|
||||
|
||||
(create-response
|
||||
(lambda (headers writer-proc)
|
||||
(make-response code
|
||||
#f
|
||||
(time)
|
||||
"text/html"
|
||||
headers
|
||||
(make-writer-body writer-proc)))))
|
||||
|
||||
(cond
|
||||
;; This error response requires two args: message is the new URI: field,
|
||||
;; and the first EXTRA is the older Location: field.
|
||||
((or (eq? code (status-code moved-temp))
|
||||
(eq? code (status-code moved-perm)))
|
||||
(create-response
|
||||
(list (cons 'uri message)
|
||||
(cons 'location (car extras)))
|
||||
(lambda (port options)
|
||||
(title-html port "Document moved")
|
||||
(format port
|
||||
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
|
||||
(if (eq? code (status-code moved-temp))
|
||||
"temporarily"
|
||||
"permanently")
|
||||
message)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code bad-request))
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(write-string "<P>Client sent a query that this server could not understand.\n"
|
||||
port)
|
||||
(send-message port)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code method-not-allowed))
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(write-string "<P>Method not allowed.\n" port)
|
||||
(send-message port)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code unauthorized))
|
||||
(create-response
|
||||
(list (cons 'WWW-Authenticate message)) ; Vas is das?
|
||||
;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47
|
||||
;; message should be a challenge(?)
|
||||
(lambda (port options)
|
||||
(title-html port "Authorization Required")
|
||||
(write-string "<P>Browser not authentication-capable or\n" port)
|
||||
(write-string "authentication failed.\n" port)
|
||||
(send-message port)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code forbidden))
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(title-html port "Request not allowed.")
|
||||
(format port
|
||||
"Your client does not have permission to perform a ~A~%"
|
||||
(request-method req))
|
||||
(format port "operation on url ~a.~%" (request-uri req))
|
||||
(send-message port)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code not-found))
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(title-html port "URL not found")
|
||||
(write-string
|
||||
"<P>The requested URL was not found on this server.\n"
|
||||
port)
|
||||
(send-message port)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code internal-error))
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(format port "The server encountered an internal error or
|
||||
misconfiguration and was unable to complete your request.
|
||||
<P>
|
||||
Please inform the server administrator, ~A, of the circumstances leading to
|
||||
the error, and time it occurred.~%"
|
||||
(or (httpd-options-server-admin options)
|
||||
"[no mail address available]"))
|
||||
(send-message port)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code not-implemented))
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(format port "This server does not currently implement
|
||||
the requested method (~A).~%"
|
||||
(request-method req))
|
||||
(send-message port)
|
||||
(close-html port))))
|
||||
|
||||
((eq? code (status-code bad-gateway))
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(format port "An error occurred while waiting for the
|
||||
response of a gateway.~%")
|
||||
(send-message port)
|
||||
(close-html port)))))))
|
||||
|
||||
(define (title-html out message)
|
||||
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
|
||||
(format out "<BODY>~%<H1>~A</H1>~%" message))
|
||||
|
||||
;; Creates a redirect response. The server will serve the new file
|
||||
;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and
|
||||
;; begin with a slash. This is intended for CGI scripts. Note that
|
||||
;; the browser won't notice the redirect. Thus, it will keep the
|
||||
;; original URL. For "real" redirections, use
|
||||
;; (make-error-response (status-code moved-perm) req
|
||||
;; "new-location" "new-location").
|
||||
(define (make-redirect-response new-location)
|
||||
(make-response
|
||||
(status-code redirect)
|
||||
#f
|
||||
(time)
|
||||
""
|
||||
'()
|
||||
(make-redirect-body new-location)))
|
||||
|
|
@ -1,196 +0,0 @@
|
|||
;;; man page -> HTML gateway for the SU web server. -*- Scheme -*-
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
|
||||
;;; Copyright (c) 1996-2003 by Mike Sperber.
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
;;; This uses RosettaMan
|
||||
;;; (based at ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
|
||||
|
||||
(define (rman-handler man-binary
|
||||
nroff-binary
|
||||
rman-binary
|
||||
gzcat-binary
|
||||
finder referencer address . maybe-man)
|
||||
(let ((parse-man-url
|
||||
(cond
|
||||
((procedure? finder) finder)
|
||||
((list? finder)
|
||||
(lambda (url)
|
||||
(values finder
|
||||
(unescape-uri (http-url-search url))
|
||||
'())))
|
||||
(else
|
||||
(let ((man-path
|
||||
((infix-splitter ":")
|
||||
(or (getenv "MANPATH")
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"~%Warning: environment variable MANPATH is unset.~%")
|
||||
"")))))
|
||||
(lambda (url)
|
||||
(values man-path
|
||||
(unescape-uri (http-url-search url))
|
||||
'()))))))
|
||||
(reference-template
|
||||
(cond
|
||||
((procedure? referencer) referencer)
|
||||
((string? referencer) (lambda (entry section) referencer))
|
||||
(else (lambda (entry section) "man?%s(%s)"))))
|
||||
(man (:optional maybe-man man)))
|
||||
|
||||
(lambda (path req)
|
||||
(let ((request-method (request-method req)))
|
||||
(cond
|
||||
((string=? request-method "GET")
|
||||
(with-fatal-error-handler
|
||||
(lambda (c decline)
|
||||
(cond
|
||||
((http-error? c)
|
||||
(apply http-error (car (condition-stuff c)) req
|
||||
(cddr (condition-stuff c))))
|
||||
(else
|
||||
(decline))))
|
||||
|
||||
(make-response
|
||||
(status-code ok)
|
||||
#f
|
||||
(time)
|
||||
"text/html"
|
||||
'()
|
||||
(make-writer-body
|
||||
(lambda (out options)
|
||||
(receive (man-path entry and-then)
|
||||
(parse-man-url (request-url req))
|
||||
(emit-man-page man-binary nroff-binary rman-binary
|
||||
gzcat-binary
|
||||
entry man man-path and-then reference-template out))
|
||||
|
||||
(with-tag out address ()
|
||||
(display address out)))))))
|
||||
(else
|
||||
(make-error-response (status-code method-not-allowed) req
|
||||
request-method)))))))
|
||||
|
||||
(define (cat-man-page key section out)
|
||||
(let ((title (if section
|
||||
(format #f "~a(~a) manual page" key section)
|
||||
(format #f "~a manual page" key))))
|
||||
(emit-title out title)
|
||||
(emit-header out 1 title)
|
||||
(newline out)
|
||||
(with-tag out body ()
|
||||
(with-tag out pre ()
|
||||
(copy-inport->outport (current-input-port)
|
||||
out)))))
|
||||
|
||||
(define (emit-man-page man-binary nroff-binary rman-binary
|
||||
gzcat-binary
|
||||
entry man man-path and-then reference-template out)
|
||||
(receive (key section) (parse-man-entry entry)
|
||||
(let ((status
|
||||
(cond
|
||||
((procedure? and-then)
|
||||
(run (| (begin (man man-binary nroff-binary gzcat-binary
|
||||
section key man-path))
|
||||
(begin (and-then key section out)))
|
||||
(= 1 ,out)
|
||||
(= 2 ,out)))
|
||||
(else
|
||||
(run (| (begin (man man-binary nroff-binary gzcat-binary
|
||||
section key man-path))
|
||||
(,rman-binary "-fHTML"
|
||||
,@and-then
|
||||
"-r" ,(reference-template entry section)))
|
||||
(= 1 ,out)
|
||||
(= 2 ,out))))))
|
||||
|
||||
(if (not (zero? status))
|
||||
(error "internal error emitting man page")))))
|
||||
|
||||
(define parse-man-entry
|
||||
(let ((entry-regexp (make-regexp "(.*)\\((.)\\)")))
|
||||
(lambda (s)
|
||||
(cond
|
||||
((regexp-exec entry-regexp s)
|
||||
=> (lambda (match)
|
||||
(values (match:substring match 1)
|
||||
(match:substring match 2))))
|
||||
(else (values s #f))))))
|
||||
|
||||
(define (man man-binary nroff-binary gzcat-binary section key man-path)
|
||||
(cond
|
||||
((procedure? man-path) (man-path))
|
||||
((find-man-file key section "cat" man-path) =>
|
||||
(lambda (file)
|
||||
(cat-n-decode gzcat-binary file)))
|
||||
((find-man-file key section "man" man-path) =>
|
||||
(lambda (file)
|
||||
(nroff-n-decode nroff-binary gzcat-binary file)))
|
||||
(else
|
||||
(if (not (zero?
|
||||
(with-env (("MANPATH" . ,(string-join man-path ":")))
|
||||
(run (,man-binary "-man" ,@(if section `(,section) '()) ,key)
|
||||
stdports))))
|
||||
(http-error (status-code not-found) #f "man page not found")))))
|
||||
|
||||
(define man-default-sections
|
||||
'("1" "2" "3" "4" "5" "6" "7" "8" "9" "o" "l" "n" "p"))
|
||||
|
||||
(define (find-man-file name section cat-man man-path . maybe-sections)
|
||||
|
||||
(define (section-dir section)
|
||||
(lambda (dir)
|
||||
(file-name-as-directory
|
||||
(string-append (file-name-as-directory dir)
|
||||
cat-man
|
||||
section))))
|
||||
|
||||
(let* ((prefix (if section
|
||||
(string-append name "." section)
|
||||
(string-append name ".")))
|
||||
(pattern (string-append (glob-quote prefix) "*"))
|
||||
(sections (:optional maybe-sections man-default-sections))
|
||||
(path (if section
|
||||
(map (section-dir section) man-path)
|
||||
(apply append
|
||||
(map (lambda (dir)
|
||||
(map (lambda (section)
|
||||
((section-dir section) dir))
|
||||
sections))
|
||||
man-path)))))
|
||||
|
||||
(let loop ((path path))
|
||||
(and (not (null? path))
|
||||
(let ((matches (glob (string-append (car path) pattern))))
|
||||
(if (not (null? matches))
|
||||
(car matches)
|
||||
(loop (cdr path))))))))
|
||||
|
||||
(define (file->man-directory file)
|
||||
(path-list->file-name
|
||||
(reverse
|
||||
(cdr
|
||||
(reverse
|
||||
(split-file-name
|
||||
(file-name-directory file)))))))
|
||||
|
||||
(define (cat-n-decode gzcat-binary file)
|
||||
(let ((ext (file-name-extension file)))
|
||||
(cond
|
||||
((string=? ".gz" ext) (run (,gzcat-binary ,file) stdports))
|
||||
((string=? ".Z" ext) (run (,gzcat-binary ,file) stdports))
|
||||
(else (call-with-input-file
|
||||
file
|
||||
(lambda (port)
|
||||
(copy-inport->outport port (current-output-port))))))))
|
||||
|
||||
(define (nroff-n-decode nroff-binary gzcat-binary file)
|
||||
(if (not (zero? (run (| (begin (cat-n-decode gzcat-binary file))
|
||||
(begin
|
||||
(with-cwd (file->man-directory file)
|
||||
(exec-epf (,nroff-binary "-man")))))
|
||||
stdports)))
|
||||
(http-error (status-code not-found) #f "man page not found")))
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
#!/bin/sh
|
||||
IFS=" "
|
||||
exec scsh -lm ../packages.scm -dm -o http-top -e top -s "$0" "$@"
|
||||
!#
|
||||
|
||||
;;; Scheme Underground Web Server -*- Scheme -*-
|
||||
;;; Olin Shivers
|
||||
|
||||
;;; To compile as a heap-image:
|
||||
;;; ,open http-top
|
||||
;;; (dump-scsh-program top "server")
|
||||
;;; then insert a #! trigger.
|
||||
|
||||
(define-structure http-top (export top)
|
||||
(open httpd-core
|
||||
httpd-make-options
|
||||
httpd-cgi-server
|
||||
httpd-basic-handlers
|
||||
httpd-seval-handlers
|
||||
scheme-with-scsh)
|
||||
(begin
|
||||
|
||||
;; Kitchen-sink request handler.
|
||||
|
||||
(define rh
|
||||
(alist-path-dispatcher
|
||||
`(("h" . ,(home-dir-handler "public_html"))
|
||||
("seval" . ,seval-handler)
|
||||
("cgi-bin" . ,(cgi-handler "/usr/local/etc/httpd/cgi-bin")))
|
||||
(tilde-home-dir-handler "public_html"
|
||||
(rooted-file-handler "/usr/local/etc/httpd/htdocs"))))
|
||||
|
||||
|
||||
|
||||
;; crank up a server on port 8001, first resetting our identity to
|
||||
;; user "nobody". Initialise the request-invariant part of the CGI
|
||||
;; env before starting.
|
||||
|
||||
(define (top args)
|
||||
(display "We be jammin, now.\n") (force-output)
|
||||
(cond ((zero? (user-uid))
|
||||
(set-gid (->gid "nobody"))
|
||||
(set-uid (->uid "nobody"))))
|
||||
;; invariant environment is know initilialized by cgi-handler itself
|
||||
;; (initialise-request-invariant-cgi-env)
|
||||
(httpd (with-request-handler
|
||||
rh
|
||||
(with-port
|
||||
8001
|
||||
(with-root-directory "/usr/local/etc/httpd")))))))
|
||||
|
|
@ -1,106 +0,0 @@
|
|||
;;; Path handler for uploading Scheme code to the SU web server -*- Scheme -*-
|
||||
|
||||
;;; This file is part of the Scheme Untergrund Networking package.
|
||||
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
;;; For copyright information, see the file COPYING which comes with
|
||||
;;; the distribution.
|
||||
|
||||
;;; This is really just an handler example demonstrating how to upload code
|
||||
;;; into the server.
|
||||
|
||||
;;; (do/timeout secs thunk)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds.
|
||||
;;; Returns nothing useful, and THUNK gets executed in a subprocess,
|
||||
;;; so its side-effects are invisible, as well. This is a clever kludge --
|
||||
;;; it uses three subprocesses -- but I don't have interrupts, so I'm hosed.
|
||||
|
||||
(define (do/timeout* secs thunk)
|
||||
(run (begin (let ((timer (fork (lambda () (sleep secs))))
|
||||
(worker (fork thunk)))
|
||||
(receive (process status) (wait-any)
|
||||
(ignore-errors
|
||||
(lambda ()
|
||||
(signal-process (proc:pid (if (eq? worker process)
|
||||
timer
|
||||
worker))
|
||||
signal/kill))))))))
|
||||
(define-syntax do/timeout
|
||||
(syntax-rules ()
|
||||
((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))
|
||||
|
||||
;;; The request handler for seval ops.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (seval-handler path req)
|
||||
(let ((request-method (request-method req)))
|
||||
(cond
|
||||
((string=? request-method "POST") ; Could do others also.
|
||||
(seval path req))
|
||||
(else
|
||||
(make-error-response (status-code method-not-allowed) req request-method)))))
|
||||
|
||||
(define (seval path req)
|
||||
(make-response
|
||||
(status-code ok)
|
||||
#f
|
||||
(time)
|
||||
"text/html"
|
||||
'()
|
||||
(make-reader-writer-body
|
||||
(lambda (iport oport options)
|
||||
(let ((sexp (read-request-sexp req iport)))
|
||||
(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
|
||||
(with-tag oport HEAD ()
|
||||
(newline oport)
|
||||
(emit-title oport "Scheme program output"))
|
||||
(newline oport)
|
||||
|
||||
(with-tag oport BODY ()
|
||||
(newline oport)
|
||||
(do/timeout
|
||||
10
|
||||
(receive vals
|
||||
;; Do the computation.
|
||||
(begin (emit-header oport 2 "Output from execution")
|
||||
(newline oport)
|
||||
(with-tag oport PRE ()
|
||||
(newline oport)
|
||||
(force-output oport); In case we're gunned down.
|
||||
(with-current-output-port oport
|
||||
(eval-safely sexp))))
|
||||
|
||||
;; Pretty-print the returned value(s).
|
||||
(emit-header oport 2 "Return value(s)")
|
||||
(with-tag oport PRE ()
|
||||
(for-each (lambda (val) (p val oport))
|
||||
vals))))))))))
|
||||
|
||||
|
||||
;;; Read an HTTP request entity body from stdin. The Content-length:
|
||||
;;; element of request REQ's header tells how many bytes to this entity
|
||||
;;; is. The entity should be a URI-encoded form body. Pull out the
|
||||
;;; program=<stuff>
|
||||
;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
|
||||
;;; and return it.
|
||||
|
||||
(define (read-request-sexp req iport)
|
||||
(cond
|
||||
((get-header (request-headers req) 'content-length) =>
|
||||
(lambda (cl-str) ; Take the first Content-length: header,
|
||||
(let* ((cl-start (string-skip cl-str char-set:whitespace)) ; skip whitespace,
|
||||
(cl (if cl-start ; & convert to
|
||||
(string->number (substring cl-str ; a number.
|
||||
cl-start
|
||||
(string-length cl-str)))
|
||||
0)) ; All whitespace?? -- WTF.
|
||||
(qs (read-string cl iport)) ; Read in CL chars,
|
||||
(q (parse-html-form-query qs)) ; and parse them up.
|
||||
(s (cond ((assoc "program" q) => cdr)
|
||||
(else (error "No program in entity body.")))))
|
||||
(http-syslog (syslog-level debug)
|
||||
"Seval sexp: ~s" s)
|
||||
(read (make-string-input-port s)))))
|
||||
(else (error "No `Content-length:' field in POST request."))))
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
TODO
|
||||
inspecting-packages.scm
|
||||
inspecting-surflet-handler.scm
|
||||
load-inspecting-surflet-server.scm
|
||||
*.aux
|
||||
*.log
|
||||
|
||||
*.dvi
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
--- SSAX-old/lib/packages.scm Sun Apr 14 07:35:07 2002
|
||||
+++ SSAX/lib/packages.scm Mon Oct 6 12:05:58 2003
|
||||
@@ -55,7 +55,7 @@
|
||||
(export SXML->HTML
|
||||
enattr
|
||||
entag
|
||||
- string->goodhtml))
|
||||
+ string->goodHTML))
|
||||
|
||||
(define-interface sxml-to-html-ext-interface
|
||||
(export make-header
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
* alias for extract-single-binding (extract/single) and extract-bindings
|
||||
(extract)?
|
||||
* send error 411 "Length required" in get-content-length (bindings.scm)
|
||||
if the content-length-header is missing.
|
||||
* use internal-error, if surflet fails, not bad gateway
|
||||
* don't let callback-functions return.
|
||||
* use another name for callback-functor.
|
||||
* tell in howto how to start in cygwin environment.
|
||||
HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Wins\Parameters
|
||||
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; return address
|
||||
|
||||
;; generates an unique return-address
|
||||
;; may be used like
|
||||
;; (let ((address (make-address)))
|
||||
;; (send-html/suspend
|
||||
;; (lambda (new-url)
|
||||
;; ...
|
||||
;; (url (address new-url) "Click here to get more")...)
|
||||
|
||||
(define-record-type address :address
|
||||
(make-address-record name annotated? annotations)
|
||||
(name address-name)
|
||||
(annotated? address-annotated?)
|
||||
(annotations address-annotations set-address-annotations!))
|
||||
|
||||
(define (really-make-address name annotated?)
|
||||
(if annotated?
|
||||
(make-address-record name annotated? #f)
|
||||
(make-address-record name annotated? '())))
|
||||
|
||||
(define (address-add-annotation! address annotation)
|
||||
(let ((index (generate-unique-name "val")))
|
||||
(set-address-annotations! address
|
||||
(cons (cons index annotation)
|
||||
(address-annotations address)))
|
||||
index))
|
||||
|
||||
(define (address-annotation address index)
|
||||
(cond
|
||||
((assoc index (address-annotations address)) => cdr)
|
||||
(else #f)))
|
||||
|
||||
(define (make-address)
|
||||
(let ((address (really-make-address
|
||||
(generate-unique-name "return") #f)))
|
||||
(lambda (message)
|
||||
(cond
|
||||
((string? message)
|
||||
(string-append message "?" (address-name address) "="))
|
||||
((eq? message 'address)
|
||||
address)
|
||||
(else
|
||||
(error "address: unknown message/bad argument"
|
||||
message (address-name address)))))))
|
||||
|
||||
(define (make-annotated-address)
|
||||
(let ((address (really-make-address
|
||||
(generate-unique-name "return")
|
||||
#t)))
|
||||
(lambda (message . annotation)
|
||||
(cond
|
||||
((and (string? message)
|
||||
(<= (length annotation) 1))
|
||||
(let ((index (if (null? annotation)
|
||||
(address-add-annotation! address "")
|
||||
(address-add-annotation! address (car annotation)))))
|
||||
(string-append message "?" (address-name address)
|
||||
"=" index)))
|
||||
((eq? message 'address)
|
||||
address)
|
||||
(else
|
||||
(error "annotated-address: unknown message/bad argument(s)"
|
||||
message (address-name address)))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,111 +0,0 @@
|
|||
;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
;; Bindings of POST requests can be read only once, since they are
|
||||
;; read from an input port. So we have to cache them, for the case of
|
||||
;; a later GET-BINDINGS call on the same POST request. The requests
|
||||
;; are referenced by a weak pointer. Thread-safe as all threads use
|
||||
;; the same lock.
|
||||
(define *POST-bindings-cache* '())
|
||||
(define *cache-lock* (make-lock))
|
||||
|
||||
(define (get-bindings surflet-request)
|
||||
(let ((request-method (surflet-request-method surflet-request))
|
||||
(content-type (assoc 'content-type
|
||||
(surflet-request-headers surflet-request))))
|
||||
|
||||
;; Check if we the content-type is the one we support. If there's
|
||||
;; no content-type, assume the default (this is the one we
|
||||
;; support).
|
||||
(if (and content-type
|
||||
;; Have to string-trim now, because the (buggy?) rfc822
|
||||
;; implementation leaves the leading whitespace of the
|
||||
;; header value.
|
||||
(not (string=? (string-trim (cdr content-type))
|
||||
"application/x-www-form-urlencoded")))
|
||||
(error "get-bindings currently only supports
|
||||
'application/x-www-form-urlencoded' as content-type"))
|
||||
(cond
|
||||
((string=? request-method "GET")
|
||||
(form-query-list (http-url-search
|
||||
(surflet-request-url surflet-request))))
|
||||
((string=? request-method "POST")
|
||||
(or (cached-bindings surflet-request)
|
||||
(let* ((content-length (get-content-length
|
||||
(surflet-request-headers surflet-request)))
|
||||
(input-port (surflet-request-input-port surflet-request))
|
||||
(form-data (read-string content-length input-port))
|
||||
(form-bindings (form-query-list form-data)))
|
||||
(obtain-lock *cache-lock*)
|
||||
(set! *POST-bindings-cache*
|
||||
(cons (cons (make-weak-pointer surflet-request)
|
||||
form-bindings)
|
||||
*POST-bindings-cache*))
|
||||
(release-lock *cache-lock*)
|
||||
form-bindings)))
|
||||
(else
|
||||
(error "unsupported request type")))))
|
||||
|
||||
;; Looking up, if we have cached this request. While going through the
|
||||
;; list, we remove entries to request objects, that are no longer
|
||||
;; valid. Expecting a call for an uncached request every now and then,
|
||||
;; it is guaranteed, that the list is cleaned up every now and
|
||||
;; then. The cache is a list of pairs
|
||||
;;; (surflet-request . computed-binding)
|
||||
(define (cached-bindings surflet-request)
|
||||
(obtain-lock *cache-lock*)
|
||||
(let ((result
|
||||
(let loop ((predecessor #f)
|
||||
(cache *POST-bindings-cache*))
|
||||
(if (null? cache)
|
||||
#f ; no such request cached
|
||||
(let* ((head (car cache))
|
||||
(s-req (weak-pointer-ref (car head))))
|
||||
(if s-req
|
||||
(if (eq? s-req surflet-request)
|
||||
(cdr head) ; request is cached
|
||||
(loop (if predecessor
|
||||
(cdr predecessor)
|
||||
cache)
|
||||
(cdr cache))) ; request isn't cached
|
||||
(begin ;; request object is gone ==> remove
|
||||
;; it from list
|
||||
(if predecessor
|
||||
(set-cdr! predecessor (cdr cache))
|
||||
(set! *POST-bindings-cache* (cdr cache)))
|
||||
(loop predecessor
|
||||
(cdr cache)))))))))
|
||||
(release-lock *cache-lock*)
|
||||
result))
|
||||
|
||||
|
||||
;; Will be needed when we handle POST requests.
|
||||
(define (get-content-length headers)
|
||||
(cond ((get-header headers 'content-length) =>
|
||||
;; adopted from httpd/cgi-server.scm
|
||||
(lambda (content-length) ; Skip initial whitespace (& other non-digits).
|
||||
(let ((first-digit (string-index content-length char-set:digit))
|
||||
(content-length-len (string-length content-length)))
|
||||
(if first-digit
|
||||
(string->number (substring content-length first-digit
|
||||
content-length-len))
|
||||
;; (status-code bad-request) req
|
||||
(error "Illegal `Content-length:' header.")))))
|
||||
(else
|
||||
(error "No Content-length specified for POST data."))))
|
||||
|
||||
(define (extract-bindings key bindings)
|
||||
(let ((key (if (symbol? key) (symbol->string key) key)))
|
||||
(map cdr
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) key))
|
||||
bindings))))
|
||||
|
||||
(define (extract-single-binding key bindings)
|
||||
(let ((key-bindings (extract-bindings key bindings)))
|
||||
(if (= 1 (length key-bindings))
|
||||
(car key-bindings)
|
||||
(error "extract-one-binding: more than one or zero bindings found"
|
||||
(length key-bindings)
|
||||
key bindings))))
|
||||
|
||||
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
;; With callbacks you can create special links that are associated
|
||||
;; with a function. If the user clicks on the special callback link,
|
||||
;; the send-html/suspend won't return, but the function will be called
|
||||
;; instead.
|
||||
|
||||
;; NOTE: It is not sensible to create callbacks on top level, as they
|
||||
;; contain continuations. You have to create a new callback every time
|
||||
;; you want to use it (inside a function).
|
||||
(define (make-callback function)
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(let* ((req (send/suspend (lambda (new-url)
|
||||
(exit new-url)))))
|
||||
(function req)))))
|
||||
|
||||
|
||||
(define (make-annotated-callback function)
|
||||
(let* ((annotated-address (make-annotated-address))
|
||||
(dispatch
|
||||
(lambda (req)
|
||||
(let ((bindings (get-bindings req)))
|
||||
(cond
|
||||
((returned-via annotated-address bindings) =>
|
||||
(lambda (args)
|
||||
(apply function (cons req args))))
|
||||
(else
|
||||
(error "annotated-callback:
|
||||
unexpected return values from website"))))))
|
||||
(callback (make-callback dispatch)))
|
||||
(lambda args
|
||||
(annotated-address callback args))))
|
||||
|
||||
(define callback-function
|
||||
(lambda (req proc . args)
|
||||
(apply proc (cons req args))))
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Error-Handler
|
||||
;;
|
||||
;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that
|
||||
;; is catchable. We must catch everything because we also want
|
||||
;; exceptions (and warnings) to be catched (e.g. when the surflet is
|
||||
;; loaded.)
|
||||
(define (with-fatal-handler* handler thunk)
|
||||
(call-with-current-continuation
|
||||
(lambda (accept)
|
||||
((call-with-current-continuation
|
||||
(lambda (k)
|
||||
(with-handler (lambda (condition more)
|
||||
(call-with-current-continuation
|
||||
(lambda (decline)
|
||||
(k (lambda () (handler condition decline)))))
|
||||
(more)) ; Keep looking for a handler.
|
||||
(lambda () (call-with-values thunk accept)))))))))
|
||||
|
||||
(define-syntax with-fatal-handler
|
||||
(syntax-rules ()
|
||||
((with-fatal-handler handler body ...)
|
||||
(with-fatal-handler* handler
|
||||
(lambda () body ...)))))
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(define (surflet-file-name req)
|
||||
(last (http-url-path (surflet-request-url req))))
|
||||
|
||||
;; This works for all requests except for the initial one. For the
|
||||
;; initial one (main's arg) think about using instance-session-id.
|
||||
(define (my-session-id req)
|
||||
(resume-url-session-id (surflet-file-name req)))
|
||||
|
||||
;; This works for all requests except for the initial one: we don't
|
||||
;; have a continuation at this time.
|
||||
(define (my-continuation-id req)
|
||||
(resume-url-continuation-id (surflet-file-name req)))
|
||||
|
||||
;; Returns two values: session-id and continuation-id. The
|
||||
;; restrictions from my-session-id and my-continuation-id apply here
|
||||
;; as well.
|
||||
(define (my-ids req)
|
||||
(resume-url-ids (surflet-file-name req)))
|
||||
|
||||
|
|
@ -1,160 +0,0 @@
|
|||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; input-fields
|
||||
;;; defines input-fields for surflets
|
||||
|
||||
;;; Globals
|
||||
(define *input-field-trigger* `*input-field*)
|
||||
(define generate-input-field-name generate-unique-name)
|
||||
|
||||
;;; Data structure for real-input-field
|
||||
;; MULTI?: Transformer will get all bindings of request, not only the
|
||||
;; one concerning the input-field.
|
||||
(define-record-type real-input-field :real-input-field
|
||||
(make-real-input-field name type transformer
|
||||
attributes html-tree-maker
|
||||
html-tree multi?)
|
||||
real-input-field?
|
||||
(name real-input-field-name)
|
||||
(type real-input-field-type)
|
||||
(transformer real-input-field-transformer)
|
||||
(attributes real-input-field-attributes set-real-input-field-attributes!)
|
||||
(html-tree-maker real-input-field-html-tree-maker)
|
||||
(html-tree real-input-field-html-tree set-real-input-field-html-tree!)
|
||||
(multi? real-input-field-multi?))
|
||||
|
||||
(define-record-discloser :real-input-field
|
||||
(lambda (input-field)
|
||||
(list 'real-input-field
|
||||
(real-input-field-type input-field)
|
||||
(real-input-field-name input-field))))
|
||||
|
||||
;;; Fake input-field record. This is necessary, as the trigger in SXML
|
||||
;;; may only be symbols, not arbitrary values. Thus, our input-fields
|
||||
;;; must be preceeded by a trigger symbol to get recognized by the
|
||||
;;; SXML transforming routines like sxml->html.
|
||||
|
||||
;; Constructors: make-input-field, make-multi-input-field
|
||||
|
||||
;; Predicates: input-field?
|
||||
|
||||
;; Selectors: input-field-name, input-field-type,
|
||||
;; input-field-transformer, input-field-attributes,
|
||||
;; input-field-html-tree-maker, input-field-html-tree,
|
||||
;; input-field-multi?
|
||||
|
||||
;; Mutators: set-input-field-attributes!, touch-input-field!
|
||||
|
||||
;;; Constructors for input-field / multi-input-field
|
||||
(define (make-input-field name type transformer attributes
|
||||
html-tree-maker)
|
||||
(make-sxml-input-field
|
||||
(make-real-input-field name type transformer
|
||||
attributes html-tree-maker #f #f)))
|
||||
|
||||
(define (make-multi-input-field name type transformer attributes
|
||||
html-tree-maker)
|
||||
(make-sxml-input-field
|
||||
(make-real-input-field name type transformer
|
||||
attributes html-tree-maker #f #t)))
|
||||
|
||||
(define (make-sxml-input-field real-input-field)
|
||||
(list *input-field-trigger* real-input-field))
|
||||
|
||||
(define input-field-real-input-field cadr)
|
||||
|
||||
(define (input-field? input-field)
|
||||
(and (pair? input-field)
|
||||
(eq? *input-field-trigger* (car input-field))
|
||||
(real-input-field? (input-field-real-input-field input-field))))
|
||||
|
||||
|
||||
(define (make-input-field-selector selector)
|
||||
(lambda (input-field)
|
||||
(selector (input-field-real-input-field input-field))))
|
||||
|
||||
(define (make-input-field-setter setter reset?)
|
||||
(lambda (input-field value)
|
||||
(let ((real-input-field (input-field-real-input-field input-field)))
|
||||
(if reset?
|
||||
(set-real-input-field-html-tree! real-input-field #f))
|
||||
(setter real-input-field value))))
|
||||
|
||||
(define input-field-name (make-input-field-selector real-input-field-name))
|
||||
(define input-field-type (make-input-field-selector real-input-field-type))
|
||||
(define input-field-transformer
|
||||
(make-input-field-selector real-input-field-transformer))
|
||||
(define input-field-attributes
|
||||
(make-input-field-selector real-input-field-attributes))
|
||||
(define input-field-html-tree-maker
|
||||
(make-input-field-selector real-input-field-html-tree-maker))
|
||||
(define (input-field-html-tree input-field)
|
||||
(let ((real-input-field (input-field-real-input-field input-field)))
|
||||
(cond
|
||||
((real-input-field-html-tree real-input-field)
|
||||
=> identity)
|
||||
(else
|
||||
(let ((html-tree ((real-input-field-html-tree-maker real-input-field)
|
||||
input-field)))
|
||||
(set-real-input-field-html-tree! real-input-field html-tree)
|
||||
html-tree)))))
|
||||
|
||||
(define input-field-multi?
|
||||
(make-input-field-selector real-input-field-multi?))
|
||||
|
||||
(define set-input-field-attributes!
|
||||
(make-input-field-setter set-real-input-field-attributes! #t))
|
||||
;; not exported:
|
||||
(define set-input-field-html-tree!
|
||||
(make-input-field-setter set-real-input-field-html-tree! #f))
|
||||
|
||||
;; A touched input-field's html-tree will be recalculated if
|
||||
;; neccessary.
|
||||
(define (touch-input-field! input-field)
|
||||
(set-input-field-html-tree! input-field #f))
|
||||
|
||||
;; <input-field>: '(input-field <real-input-field>)
|
||||
;; <real-input-field>: #{Real-input-field "name"}
|
||||
(define (raw-input-field-value input-field bindings)
|
||||
(let ((real-input-field (input-field-real-input-field input-field)))
|
||||
(cond
|
||||
((real-input-field-multi? real-input-field)
|
||||
((real-input-field-transformer real-input-field) input-field bindings))
|
||||
((real-input-field-binding real-input-field bindings) =>
|
||||
(lambda (binding)
|
||||
((real-input-field-transformer real-input-field)
|
||||
input-field (cdr binding))))
|
||||
(else
|
||||
(error "no such input-field" input-field bindings)))))
|
||||
|
||||
;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
|
||||
;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
|
||||
;; returned. The default-value defaults to #f. NOTE: If you do this
|
||||
;; with input-fields whose valid values may be the same as the default
|
||||
;; value, you cannot determine by the result if there was such a value
|
||||
;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
|
||||
;; error, if there was not such an input field. This makes
|
||||
;; INPUT-FIELD-VALUE working with checkbox input fields because they
|
||||
;; miss if they are not checked.
|
||||
(define (input-field-value input-field bindings . maybe-default)
|
||||
(let ((default (:optional maybe-default #f)))
|
||||
(with-fatal-error-handler
|
||||
(lambda (condition more)
|
||||
; (format #t "hit error condition: ~s~%" condition)
|
||||
default)
|
||||
(raw-input-field-value input-field bindings))))
|
||||
|
||||
(define (real-input-field-binding input-field bindings)
|
||||
(assoc (real-input-field-name input-field) bindings))
|
||||
|
||||
;; Returns the binding of the input-field in bindings by the
|
||||
;; input-field's name. If your input-field will have another name in
|
||||
;; the bindings than it was created with, use a multi-input-field.
|
||||
(define (input-field-binding input-field bindings)
|
||||
(real-input-field-binding (input-field-real-input-field input-field)
|
||||
bindings))
|
||||
|
||||
|
||||
;;EOF
|
||||
|
|
@ -9,21 +9,14 @@
|
|||
|
||||
\input{../../../doc/latex/decls}
|
||||
\newcommand{\attrib}[1]{\textsf{#1}}
|
||||
\newcommand{\ovar}[1]{\mbox{\textnormal{[}\frenchspacing\it{#1}\textnormal{]}}}
|
||||
%FIXME-command: types out the desired FIXME
|
||||
\newcommand{\FIXME}[1]%
|
||||
{\typeout{}\typeout{****** FIXME ***** #1}\typeout{}%
|
||||
\textsf{[#1]}}
|
||||
|
||||
\begin{document}
|
||||
\maketitle
|
||||
\begin{abstract}
|
||||
\noindent [THIS FILE IS NOT AT ALL UP TO DATE. However, some specs
|
||||
are still true. See the sources and the example SUrflets for up to
|
||||
date info.]\\ \noindent The Scheme Untergrund Network Package
|
||||
(\textit{SUnet} for short) comes along with a modular web
|
||||
server. The SUrflet handler described here extends it by the
|
||||
capability of writing programs in Scheme, that yield an HTML page.
|
||||
\noindent The Scheme Untergrund Network Package (\textit{SUnet} for
|
||||
short) comes along with a modular web server. The SUrflet handler
|
||||
described here extends it by the capability of writing programs in
|
||||
Scheme, that yield an HTML page.
|
||||
|
||||
Suspending of SUrflet computation.
|
||||
Using Oleg's SXML.
|
||||
|
|
@ -271,7 +264,7 @@ See the examples for further informations.
|
|||
|
||||
\defun{input-field-binding}{input-field bindings}{binding}
|
||||
\defunx{raw-input-field-value}{input-field bindings}{value}
|
||||
\defunx{input-field-value}{input-field bindings \ovar{default}}{value}
|
||||
\defunx{input-field-value}{input-field bindings \opt{default}}{value}
|
||||
\begin{desc}
|
||||
\ex{input-field-binding} returns the binding for
|
||||
\semvar{input-field} in \semvar{bindings}.
|
||||
|
|
|
|||
|
|
@ -1,16 +1,35 @@
|
|||
;;; This file is meant for developing. Use the example startup
|
||||
;;; scripts to start the webserver,
|
||||
;;; e.g. $SCSH_LIB_DIRS/sunet/web-server/start-surflet-server
|
||||
|
||||
;;; Reads package descriptions in the right order. In the end, the
|
||||
;;; server can be started via SERVER. Assumes scsh has been started with
|
||||
;;; SSAX loaded: scsh -lel SSAX/load.scm (otherwise surflets won't work)
|
||||
;;; and it is called with cwd=sunet/scheme/httpd/surflets/
|
||||
; reads package description in the right order
|
||||
; in the end, the server can be started via (server)
|
||||
|
||||
(batch 'on)
|
||||
(config `(load "../../packages.scm"))
|
||||
(config `(load "packages.scm"))
|
||||
(config `(load "../../../web-server/start-surflet-server"))
|
||||
(define *ASSUMED-SUNET-HOME*
|
||||
(in 'scsh '(run (match:substring
|
||||
(regexp-search (rx (submatch (* any) "sunet")) (cwd))
|
||||
1))))
|
||||
(define *SUNET-PACKAGE*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/packages.scm"))))
|
||||
(define *SSAX-PACKAGE*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SSAXPATH")
|
||||
(string-append ,*ASSUMED-SUNET-HOME* "/SSAX"))
|
||||
"/lib/packages.scm"))))
|
||||
(define *SURFLET-PACKAGE*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/httpd/surflets/packages.scm"))))
|
||||
(define *SURFLET-SERVER*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/httpd/surflets/start-surflet-server"))))
|
||||
(config `(load ,*SUNET-PACKAGE*))
|
||||
(config `(load ,*SSAX-PACKAGE*))
|
||||
(config `(load ,*SURFLET-PACKAGE*))
|
||||
(config `(load ,*SURFLET-SERVER*))
|
||||
(user)
|
||||
(open 'surflet-server)
|
||||
(batch 'off)
|
||||
|
|
|
|||
|
|
@ -1,33 +0,0 @@
|
|||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; outdater
|
||||
|
||||
(define-record-type outdater :outdater
|
||||
(real-make-outdater outdated?)
|
||||
outdater?
|
||||
(outdated? outdater-outdated? set-outdater-outdated?!))
|
||||
|
||||
(define (make-outdater)
|
||||
(real-make-outdater #f))
|
||||
|
||||
(define-syntax if-outdated
|
||||
(syntax-rules ()
|
||||
((if-outdated outdater consequence alternative)
|
||||
(if (outdater-outdated? outdater)
|
||||
consequence
|
||||
(begin
|
||||
(set-outdater-outdated?! outdater #t)
|
||||
alternative)))))
|
||||
|
||||
(define (show-outdated url)
|
||||
(send-html
|
||||
`(html (title "Outdated Data")
|
||||
(body (h1 "Outdated Data")
|
||||
(p "The page or action you requested relies on outdated data.")
|
||||
,(if url
|
||||
`(p "Try to "
|
||||
(url ,url "reload")
|
||||
" the page to get current data.")
|
||||
'())))))
|
||||
|
|
@ -1,213 +1,221 @@
|
|||
;; Structures and interfaces for surflets.
|
||||
;; NOTE: SSAX/lib/packages.scm must be loaded before you can use this
|
||||
;; downloadable from http://sourceforge.net/project/showfiles.php?group_id=30687
|
||||
;; (take the r5rs compliant version (ssax-sr5rs-plt200-4.9.tar.gz))
|
||||
|
||||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
;;; Copyright 2002 Martin Gasbichler
|
||||
(define-interface rt-module-language-interface
|
||||
(export ((lambda-interface
|
||||
with-names-from-rt-structure)
|
||||
:syntax)
|
||||
reify-structure
|
||||
load-structure
|
||||
load-config-file
|
||||
rt-structure-binding))
|
||||
|
||||
;;; NOTE: SSAX/lib/packages.scm must be loaded before you can use this
|
||||
;;; downloadable from
|
||||
;;; http://sourceforge.net/project/showfiles.php?group_id=30687 (take
|
||||
;;; the r5rs compliant version (ssax-sr5rs-plt200-4.9.tar.gz); and
|
||||
;;; patch string->goodhtml in packages.scm to string->goodHTML)
|
||||
(define-interface rt-modules-interface
|
||||
(export interface-value-names
|
||||
reify-structure
|
||||
load-config-file
|
||||
rt-structure-binding
|
||||
load-structure))
|
||||
|
||||
(define-structure rt-module-language rt-module-language-interface
|
||||
(open scheme
|
||||
rt-modules)
|
||||
(for-syntax (open scheme
|
||||
rt-modules))
|
||||
(begin
|
||||
(define-syntax lambda-interface
|
||||
(lambda (expr rename compare)
|
||||
(let ((%lambda (rename 'lambda))
|
||||
(interface-name (cadr expr))
|
||||
(body (cddr expr)))
|
||||
`(,%lambda ,(interface-value-names interface-name) ,@body))))
|
||||
|
||||
;(with-names-from-rt-structure surflet surflet-interface (main))
|
||||
(define-syntax with-names-from-rt-structure
|
||||
(lambda (expr rename compare)
|
||||
(let ((%lambda (rename 'lambda))
|
||||
(%let (rename 'let))
|
||||
(%rt-structure-value (rename 'rt-structure-value))
|
||||
(%rt-structure-binding (rename 'rt-structure-binding))
|
||||
(rt-structure (cadr expr))
|
||||
(interface-name (caddr expr))
|
||||
(body (cdddr expr)))
|
||||
(let ((ivn (interface-value-names interface-name)))
|
||||
`(,%let ((,%rt-structure-value ,rt-structure))
|
||||
((,%lambda ,ivn ,@body)
|
||||
,@(map (lambda (name)
|
||||
`(,%rt-structure-binding ,%rt-structure-value ',name))
|
||||
ivn)))))))))
|
||||
|
||||
(define-structure rt-modules rt-modules-interface
|
||||
(open scheme
|
||||
meta-types ; syntax-type
|
||||
interfaces ; for-each-declaration
|
||||
define-record-types
|
||||
records
|
||||
signals
|
||||
bindings
|
||||
packages
|
||||
packages-internal
|
||||
locations
|
||||
environments
|
||||
ensures-loaded
|
||||
package-commands-internal)
|
||||
(files rt-module))
|
||||
|
||||
;;; Interfaces
|
||||
;; Surflet Handler
|
||||
(define-interface surflet-handler-interface
|
||||
(export surflet-handler))
|
||||
|
||||
;; Responses from SUrflets
|
||||
(define-interface surflet-handler/responses-interface
|
||||
(export make-surflet-response
|
||||
valid-surflet-response-data?
|
||||
surflet-response?
|
||||
surflet-response-status
|
||||
surflet-response-content-type
|
||||
surflet-response-headers
|
||||
surflet-response-data))
|
||||
(define-interface surflet-handler/surflet-interface
|
||||
(export send/suspend ;send and suspend
|
||||
send/finish ;send and finish
|
||||
send ;just send (no finish, no suspend)
|
||||
set-surflet-data!
|
||||
get-surflet-data
|
||||
adjust-timeout ;adjusts timeout of current session
|
||||
;Without `!' because PLT
|
||||
;doesn't have it.
|
||||
))
|
||||
|
||||
;; SUrflet-requests as expected from the surflet handler
|
||||
(define-interface surflet-handler/requests-interface
|
||||
(export make-surflet-request ;FIXME? unusable for user
|
||||
surflet-request?
|
||||
surflet-request-request
|
||||
surflet-request-input-port
|
||||
surflet-request-method
|
||||
surflet-request-uri
|
||||
surflet-request-url
|
||||
surflet-request-version
|
||||
surflet-request-headers
|
||||
surflet-request-socket))
|
||||
|
||||
(define-interface surflets/error-interface
|
||||
(export send-error ;send error response
|
||||
(status-code :syntax))) ;from httpd-responses
|
||||
|
||||
;; Use for SUrflets
|
||||
(define-interface surflet-handler/primitives-interface
|
||||
(compound-interface
|
||||
surflet-handler/responses-interface
|
||||
surflet-handler/requests-interface
|
||||
surflets/error-interface
|
||||
(export send/suspend ;send and suspend
|
||||
send/finish ;send and finish
|
||||
send ;just send (no finish, no suspend)
|
||||
)))
|
||||
|
||||
|
||||
;; Send HTML-Strings (for advanced user)
|
||||
(define-interface surflets/send-html-string-interface
|
||||
(export send-html-string/suspend
|
||||
send-html-string/finish
|
||||
send-html-string))
|
||||
|
||||
;; Extensions/Exports to/from Olegs SSAX library
|
||||
(define-interface surflets/sxml-interface
|
||||
(export display-low-level-sxml
|
||||
sxml->low-level-sxml ;direct map to pre-post-order
|
||||
sxml->string
|
||||
sxml->string/internal
|
||||
sxml-attribute?
|
||||
sxml-attribute-attributes
|
||||
default-rule
|
||||
text-rule
|
||||
attribute-rule))
|
||||
|
||||
;; SUrflets' extensions to SXML
|
||||
(define-interface surflets/surflet-sxml-interface
|
||||
(export surflet-sxml->low-level-sxml
|
||||
surflet-sxml-rules
|
||||
surflet-form-rule
|
||||
default-rules
|
||||
plain-html-rule
|
||||
nbsp-rule
|
||||
url-rule))
|
||||
|
||||
;; Use for advanced users: make your own conversion rules.
|
||||
(define-interface surflets/my-sxml-interface
|
||||
(compound-interface
|
||||
surflets/send-html-string-interface
|
||||
surflets/sxml-interface
|
||||
surflets/surflet-sxml-interface))
|
||||
|
||||
(define-interface surflets/continuations-interface
|
||||
(export get-continuations
|
||||
delete-continuation!
|
||||
continuation-id))
|
||||
|
||||
;; Access to session-id and continuation-id
|
||||
(define-interface surflets/ids-interface
|
||||
(export my-session-id
|
||||
my-continuation-id
|
||||
my-ids
|
||||
instance-session-id))
|
||||
|
||||
(define-interface surflets/session-data-interface
|
||||
(export get-session-data
|
||||
set-session-data!))
|
||||
|
||||
;; Use for advanced users: access to your sessions and continuations
|
||||
;; (currently you get access to all sessions; this should and will be
|
||||
;; restricted in the future)
|
||||
(define-interface surflets/my-sessions-interface
|
||||
(compound-interface
|
||||
surflets/ids-interface
|
||||
surflets/continuations-interface
|
||||
surflets/session-data-interface
|
||||
(export get-session
|
||||
;; That would be too much:
|
||||
;; get-sessions
|
||||
delete-session!
|
||||
instance-session-id
|
||||
session-adjust-timeout!
|
||||
adjust-timeout!
|
||||
session-alive?
|
||||
session-surflet-name
|
||||
session-session-id
|
||||
set-session-lifetime!
|
||||
options-surflet-path
|
||||
options-session-lifetime
|
||||
options-cache-surflets?
|
||||
options-make-session-timeout-text)))
|
||||
|
||||
(define-interface surflets/sessions-interface
|
||||
(compound-interface
|
||||
surflets/session-data-interface
|
||||
(export get-session
|
||||
get-sessions
|
||||
delete-session!
|
||||
instance-session-id
|
||||
set-session-lifetime!
|
||||
adjust-timeout!
|
||||
session-adjust-timeout!
|
||||
session-alive?
|
||||
session-surflet-name
|
||||
session-session-id ;faked
|
||||
;; FIXME: This is too much and should be restricted:
|
||||
session-continuation-table
|
||||
session-continuation-table-lock
|
||||
session-continuation-counter)))
|
||||
|
||||
(define-interface surflet-handler/surflets-interface
|
||||
(define-interface surflet-handler/admin-interface
|
||||
(export get-loaded-surflets
|
||||
unload-surflet
|
||||
reset-surflet-cache!))
|
||||
|
||||
(define-interface surflet-handler/options-interface
|
||||
(export make-surflet-options
|
||||
with-surflet-path
|
||||
with-session-lifetime
|
||||
with-cache-surflets?
|
||||
with-make-session-timeout-text
|
||||
options-surflet-path
|
||||
options-session-lifetime
|
||||
set-options-session-lifetime
|
||||
options-session-lifetime
|
||||
set-options-cache-surflets?
|
||||
options-cache-surflets?
|
||||
options-make-session-timeout-text
|
||||
set-options-surflet-path!
|
||||
set-options-session-lifetime!
|
||||
set-options-cache-surflets?!
|
||||
set-options-make-session-timeout-text))
|
||||
|
||||
(define-interface surflet-handler/resume-url-interface
|
||||
(export resume-url?
|
||||
options-surflet-path
|
||||
options-surflet-prefix
|
||||
get-sessions
|
||||
session-surflet-name
|
||||
session-memo
|
||||
session-continuation-table
|
||||
session-continuation-table-lock
|
||||
session-continuation-counter
|
||||
delete-session!
|
||||
session-adjust-timeout!
|
||||
adjust-timeout
|
||||
get-continuations
|
||||
delete-continuation!
|
||||
instance-session-id
|
||||
resume-url?
|
||||
resume-url-ids
|
||||
resume-url-session-id
|
||||
resume-url-continuation-id))
|
||||
|
||||
;; Use for adminstration of the Surflet Handler
|
||||
(define-interface surflet-handler/admin-interface
|
||||
(compound-interface
|
||||
surflet-handler/surflets-interface
|
||||
surflets/sessions-interface
|
||||
surflets/continuations-interface
|
||||
surflet-handler/resume-url-interface
|
||||
surflet-handler/options-interface
|
||||
))
|
||||
(define-structures
|
||||
((surflet-handler surflet-handler-interface)
|
||||
(surflet-handler/surflet surflet-handler/surflet-interface)
|
||||
(surflet-handler/admin surflet-handler/admin-interface))
|
||||
(open httpd-responses
|
||||
httpd-requests
|
||||
httpd-errors
|
||||
uri ;URI-PATH-LIST->PATH
|
||||
tables ;HASH-TABLES
|
||||
define-record-types ;DEFINE-RECORD-TYPE
|
||||
rt-module-language ;get structures dynamically
|
||||
; srfi-13 ;string
|
||||
srfi-14 ;CHAR-SET:DIGIT
|
||||
handle-fatal-error ;WITH-FATAL-ERROR-HANDLER* et al.
|
||||
srfi-27 ;random numbers
|
||||
locks ;MAKE-LOCK et al.
|
||||
thread-cells ;THREAD-CELL et al.
|
||||
profiling ;PROFILE-SPACE
|
||||
httpd-logging ;HTTP-SYSLOG
|
||||
shift-reset ;SHIFT and RESET
|
||||
conditions ;exception
|
||||
threads ;SLEEP
|
||||
thread-fluids ;FORK-THREAD
|
||||
sxml-to-html ;SXML->HTML
|
||||
scsh ;regexp et al.
|
||||
; httpd-file-directory-handlers ;send-file-response
|
||||
srfi-6 ;string-ports
|
||||
handle
|
||||
scheme
|
||||
)
|
||||
(files surflet-handler))
|
||||
|
||||
|
||||
(define-interface surflets-interface
|
||||
(export send/suspend
|
||||
send/finish
|
||||
send
|
||||
send-html/suspend
|
||||
send-html/finish
|
||||
send-html
|
||||
form-query
|
||||
get-bindings
|
||||
extract-bindings
|
||||
extract-single-binding
|
||||
|
||||
adjust-timeout
|
||||
|
||||
make-outdater
|
||||
(if-outdated :syntax)
|
||||
show-outdated
|
||||
|
||||
generate-input-field-name
|
||||
make-input-field
|
||||
make-higher-input-field
|
||||
make-text-input-field
|
||||
make-hidden-input-field
|
||||
make-password-input-field
|
||||
make-number-input-field
|
||||
make-textarea-input-field
|
||||
make-select-input-field
|
||||
make-checkbox-input-field
|
||||
make-radio-input-fields
|
||||
|
||||
make-submit-button
|
||||
make-reset-button
|
||||
make-image-button
|
||||
input-field-value
|
||||
raw-input-field-value
|
||||
input-field-binding
|
||||
|
||||
make-address
|
||||
returned-via?
|
||||
make-callback
|
||||
|
||||
set-surflet-data!
|
||||
get-surflet-data))
|
||||
|
||||
(define-structure surflets surflets-interface
|
||||
(open surflet-handler/surflet
|
||||
httpd-responses
|
||||
httpd-requests ; HTTP-URL:SEARCH
|
||||
url ; REQUEST:URL
|
||||
parse-html-forms
|
||||
sxml-to-html ; SXML->HTML
|
||||
srfi-1 ; FILTER
|
||||
(subset srfi-13 (string-index))
|
||||
sxml-tree-trans
|
||||
url
|
||||
define-record-types
|
||||
weak ;MAKE-WEAK-POINTER
|
||||
locks
|
||||
let-opt ;:OPTIONAL
|
||||
handle-fatal-error
|
||||
scsh
|
||||
scheme)
|
||||
(files surflets))
|
||||
|
||||
;; THE interface that SUrflets use.
|
||||
(define-interface surflet-interface
|
||||
(export main)) ; MAIN gets one parameter, the REQUEST
|
||||
|
||||
;; Simple Surflet API as known from PLT
|
||||
(define-interface simple-surflet-api-interface
|
||||
(export single-query
|
||||
queries
|
||||
form-query
|
||||
inform
|
||||
final-page
|
||||
make-text
|
||||
make-password
|
||||
make-number
|
||||
make-boolean
|
||||
make-radio
|
||||
make-yes-no
|
||||
extract/single
|
||||
extract))
|
||||
|
||||
;; shift-reset
|
||||
(define-interface shift-reset-interface
|
||||
(export (reset :syntax)
|
||||
(shift :syntax)))
|
||||
|
||||
;; For memory profiling
|
||||
(define-structure shift-reset shift-reset-interface
|
||||
(open scheme
|
||||
signals
|
||||
escapes
|
||||
thread-cells)
|
||||
(files shift-reset))
|
||||
|
||||
(define-interface profiling-interface
|
||||
(export profile-space
|
||||
profile-result
|
||||
|
|
@ -243,251 +251,6 @@
|
|||
total-count total-bytes
|
||||
))
|
||||
|
||||
;; Handling every condition
|
||||
(define-interface handle-fatal-interface
|
||||
(export with-fatal-handler*
|
||||
(with-fatal-handler :syntax)))
|
||||
|
||||
;; Thread-safe counter
|
||||
(define-interface thread-safe-counter-interface
|
||||
(export make-thread-safe-counter
|
||||
thread-safe-counter-value
|
||||
thread-safe-counter-next!
|
||||
thread-safe-counter?))
|
||||
|
||||
(define-interface with-locks-interface
|
||||
(export with-lock*
|
||||
(with-lock :syntax)))
|
||||
|
||||
;; Input-fields as Scheme-Objects
|
||||
(define-interface surflets/input-field-value-interface
|
||||
(export input-field?
|
||||
raw-input-field-value
|
||||
input-field-value
|
||||
input-field-binding))
|
||||
|
||||
;; For advanced users: creating your own input-fields
|
||||
(define-interface surflets/my-input-fields-interface
|
||||
(compound-interface
|
||||
surflets/input-field-value-interface
|
||||
(export generate-input-field-name
|
||||
make-input-field
|
||||
make-multi-input-field
|
||||
input-field-name
|
||||
input-field-type
|
||||
input-field-transformer
|
||||
input-field-attributes
|
||||
input-field-html-tree-maker
|
||||
input-field-html-tree
|
||||
input-field-multi?
|
||||
set-input-field-attributes!
|
||||
touch-input-field!)))
|
||||
|
||||
;; For internal use: special exports to create
|
||||
;; SXL-rules for input-fields
|
||||
(define-interface surflets/internal-input-fields-interface
|
||||
(export *input-field-trigger*
|
||||
make-sxml-input-field))
|
||||
|
||||
(define-interface surflets/surflet-input-fields-interface
|
||||
(compound-interface
|
||||
surflets/input-field-value-interface
|
||||
(export make-text-field
|
||||
set-text-field-value!
|
||||
|
||||
make-number-field
|
||||
set-number-field-value!
|
||||
|
||||
make-hidden-field
|
||||
set-hidden-field-value!
|
||||
|
||||
make-password-field
|
||||
set-password-field-value!
|
||||
|
||||
make-textarea
|
||||
set-textarea-value!
|
||||
|
||||
make-select
|
||||
make-annotated-select
|
||||
make-simple-select-option
|
||||
make-annotated-select-option
|
||||
select-option?
|
||||
select-select-option!
|
||||
unselect-select-option!
|
||||
add-select-option!
|
||||
delete-select-option!
|
||||
set-select-option-selected?!
|
||||
|
||||
make-radio-group
|
||||
make-annotated-radio-group
|
||||
make-radios
|
||||
check-radio!
|
||||
uncheck-radio!
|
||||
set-radio-checked?!
|
||||
|
||||
make-checkbox
|
||||
make-annotated-checkbox
|
||||
check-checkbox!
|
||||
uncheck-checkbox!
|
||||
set-checkbox-checked?!
|
||||
|
||||
make-submit-button
|
||||
make-reset-button
|
||||
make-image-button)))
|
||||
|
||||
;; Some utilities
|
||||
(define-interface surflets/utilities-interface
|
||||
(export form-query-list
|
||||
rev-append
|
||||
generate-unique-number
|
||||
generate-unique-name
|
||||
identity))
|
||||
|
||||
;; Intelligent Addresses
|
||||
(define-interface surflets/addresses-interface
|
||||
(export make-address
|
||||
make-annotated-address
|
||||
address-name
|
||||
address-annotated?
|
||||
; address-add-annotation!
|
||||
address-annotation))
|
||||
|
||||
(define-interface surflets/callbacks-interface
|
||||
(export make-callback
|
||||
make-annotated-callback
|
||||
callback-function))
|
||||
|
||||
;; Returned-via (dispatcher for input-fields and intelligent
|
||||
;; addresses)
|
||||
(define-interface surflets/returned-via-interface
|
||||
(export returned-via
|
||||
returned-via?
|
||||
(case-returned-via :syntax)))
|
||||
|
||||
;; Outdater denies access to outdated object
|
||||
(define-interface surflets/outdaters-interface
|
||||
(export make-outdater
|
||||
(if-outdated :syntax)
|
||||
show-outdated))
|
||||
|
||||
;; Access to form bindings in URL
|
||||
(define-interface surflets/bindings-interface
|
||||
(export get-bindings
|
||||
get-content-length
|
||||
extract-bindings
|
||||
extract-single-binding))
|
||||
|
||||
;; HTML-Extensions to send/suspend et al. (for basic user)
|
||||
(define-interface surflets/send-html-interface
|
||||
(export send-html/suspend
|
||||
send-html/finish
|
||||
send-html))
|
||||
|
||||
(define-interface surflets/send-xml-interface
|
||||
(export send-xml/finish
|
||||
send-xml/suspend))
|
||||
|
||||
;; Helping functions for surflets (for basic user)
|
||||
(define-interface surflets-interface
|
||||
(compound-interface
|
||||
; surflet-handler/surflets-interface;
|
||||
; surflets/sxml-interface
|
||||
; surflets/surflet-sxml-interface
|
||||
surflets/send-html-interface
|
||||
surflets/surflet-input-fields-interface
|
||||
surflets/addresses-interface
|
||||
surflets/returned-via-interface
|
||||
surflets/bindings-interface
|
||||
surflets/session-data-interface))
|
||||
|
||||
;;; Structures
|
||||
;; structures from SUrflet Handler
|
||||
(define-structures
|
||||
((surflet-handler surflet-handler-interface)
|
||||
(surflet-handler/surflets surflet-handler/surflets-interface)
|
||||
(surflet-handler/options surflet-handler/options-interface)
|
||||
(surflet-handler/resume-url surflet-handler/resume-url-interface)
|
||||
(surflet-handler/admin surflet-handler/admin-interface)
|
||||
(surflet-handler/primitives surflet-handler/primitives-interface)
|
||||
(surflets/sessions surflets/sessions-interface)
|
||||
(surflets/continuations surflets/continuations-interface)
|
||||
(surflets/error surflets/error-interface)
|
||||
(surflets/session-data surflets/session-data-interface))
|
||||
(open define-record-types ;DEFINE-RECORD-TYPE
|
||||
handle-fatal ;WITH-FATAL-ERROR-HANDLER* et al.
|
||||
handle-fatal-error
|
||||
httpd-errors ;errors for httpd
|
||||
httpd-logging ;HTTP-SYSLOG
|
||||
httpd-requests ;requests from httpd
|
||||
httpd-responses ;replies for httpd
|
||||
let-opt ;:OPTIONAL
|
||||
locks ;MAKE-LOCK et al.
|
||||
profiling ;PROFILE-SPACE
|
||||
rt-modules ;get structures dynamically
|
||||
scheme-with-scsh ;regexp et al.
|
||||
search-trees
|
||||
shift-reset ;SHIFT and RESET
|
||||
(subset srfi-1 (alist-cons alist-delete!))
|
||||
srfi-6 ;string-ports
|
||||
srfi-14 ;CHAR-SET:DIGIT
|
||||
srfi-27 ;random numbers
|
||||
surflet-requests ;requests for surflets
|
||||
surflet-responses ;responses from surflets
|
||||
sxml-to-html ;SXML->HTML
|
||||
tables ;HASH-TABLES
|
||||
thread-cells ;THREAD-CELL et al.
|
||||
thread-fluids ;FORK-THREAD
|
||||
thread-safe-counter
|
||||
threads ;SLEEP
|
||||
uri ;URI-PATH-LIST->PATH
|
||||
with-locks ;WITH-LOCK
|
||||
)
|
||||
(files surflet-handler))
|
||||
|
||||
;; SUrflets library of helping functions
|
||||
(define-structure surflets surflets-interface
|
||||
(open surflets/session-data
|
||||
surflets/send-html ;send-html/suspend...
|
||||
surflets/surflet-input-fields
|
||||
surflets/addresses ;annotated-address...
|
||||
surflets/returned-via
|
||||
surflets/bindings))
|
||||
|
||||
(define-structure surflets/send-xml surflets/send-xml-interface
|
||||
(open scheme
|
||||
surflets/sxml
|
||||
surflets/my-sxml
|
||||
surflet-handler/primitives
|
||||
surflet-handler/responses)
|
||||
(files send-xml))
|
||||
|
||||
;; SUrflets library for advanced users: make and use your own
|
||||
;; conversion rules.
|
||||
(define-structure surflets/my-sxml surflets/my-sxml-interface
|
||||
(open surflets/send-html-string
|
||||
surflets/sxml
|
||||
surflets/surflet-sxml))
|
||||
|
||||
;; SUrflets librarary for advanced users: access to session and
|
||||
;; continuations and stuff.
|
||||
(define-structure surflets/my-sessions surflets/my-sessions-interface
|
||||
(open surflets/ids
|
||||
surflets/continuations
|
||||
surflets/session-data
|
||||
surflet-handler/surflets
|
||||
surflets/sessions
|
||||
surflet-handler/options))
|
||||
|
||||
|
||||
;; Shift-Reset
|
||||
(define-structure shift-reset shift-reset-interface
|
||||
(open scheme
|
||||
signals
|
||||
escapes
|
||||
thread-cells)
|
||||
(files shift-reset))
|
||||
|
||||
;; Measuring memory usage.
|
||||
(define-structure profiling profiling-interface
|
||||
(open let-opt
|
||||
define-record-types
|
||||
|
|
@ -495,186 +258,31 @@
|
|||
srfi-13
|
||||
srfi-1
|
||||
locks
|
||||
scheme-with-scsh)
|
||||
scsh
|
||||
scheme)
|
||||
(files profile))
|
||||
|
||||
;; Simple Surflet API as known from PLT.
|
||||
(define-interface simple-surflet-api-interface
|
||||
(export single-query
|
||||
queries
|
||||
form-query
|
||||
inform
|
||||
final-page
|
||||
make-password
|
||||
make-number
|
||||
make-boolean
|
||||
make-radio
|
||||
make-yes-no
|
||||
extract/single
|
||||
extract))
|
||||
|
||||
(define-structure simple-surflet-api simple-surflet-api-interface
|
||||
(open scheme-with-scsh
|
||||
(open scsh
|
||||
scheme
|
||||
define-record-types
|
||||
let-opt
|
||||
surflets
|
||||
surflets/surflet-input-fields
|
||||
(subset srfi-1 (zip filter find make-list))
|
||||
handle-fatal-error
|
||||
)
|
||||
(files simple-surflet-api))
|
||||
|
||||
;; Handling every condition
|
||||
(define-structure handle-fatal handle-fatal-interface
|
||||
(open scheme conditions handle)
|
||||
(files handle-fatal))
|
||||
|
||||
|
||||
;; Thread-safe counter
|
||||
(define-structure thread-safe-counter thread-safe-counter-interface
|
||||
(open scheme
|
||||
locks
|
||||
define-record-types)
|
||||
(files thread-safe-counter))
|
||||
|
||||
;; SUrflet-requests as expected from the SUrflet handler
|
||||
;;; We have two names for the same thing to ease the use of structure
|
||||
;;; names: requests seem to be part of the surflet-handler, but are
|
||||
;;; actually seperate files. If you know everything about SUrflets,
|
||||
;;; you use `surflet-requests'.
|
||||
(define-structures
|
||||
((surflet-handler/requests surflet-handler/requests-interface)
|
||||
(surflet-requests surflet-handler/requests-interface))
|
||||
(open scheme
|
||||
define-record-types
|
||||
httpd-requests)
|
||||
(files surflet-request))
|
||||
|
||||
(define-structures
|
||||
((surflet-handler/responses surflet-handler/responses-interface)
|
||||
(surflet-responses surflet-handler/responses-interface))
|
||||
(open scheme-with-scsh
|
||||
define-record-types)
|
||||
(files surflet-response))
|
||||
|
||||
;; Extensions to Olegs SSAX library
|
||||
(define-structure surflets/sxml surflets/sxml-interface
|
||||
(open scheme-with-scsh ;string-ports
|
||||
(subset sxml-to-html (string->goodHTML entag))
|
||||
(subset sxml-tree-trans (pre-post-order)))
|
||||
(files sxml))
|
||||
|
||||
|
||||
;; Input fields as Scheme objects
|
||||
(define-structures
|
||||
((surflets/input-field-value surflets/input-field-value-interface)
|
||||
(surflets/my-input-fields surflets/my-input-fields-interface)
|
||||
(surflets/internal-input-fields surflets/internal-input-fields-interface))
|
||||
(open scheme-with-scsh ;error, format
|
||||
(subset let-opt (:optional))
|
||||
handle-fatal-error
|
||||
define-record-types
|
||||
surflets/sxml
|
||||
surflets/utilities
|
||||
)
|
||||
(files input-fields))
|
||||
|
||||
(define-structure surflets/input-fields surflets/my-input-fields)
|
||||
|
||||
(define-structure surflets/surflet-input-fields
|
||||
surflets/surflet-input-fields-interface
|
||||
(open scheme-with-scsh ;error, format
|
||||
;; avoid name collision for member
|
||||
(modify srfi-1 (rename (member member/srfi-1)))
|
||||
define-record-types
|
||||
let-opt
|
||||
surflets/my-input-fields
|
||||
surflets/utilities ;generate-unique-number
|
||||
surflets/sxml
|
||||
tables ;make-integer-table
|
||||
)
|
||||
(files surflet-input-fields))
|
||||
|
||||
|
||||
;; Extensions to SXML for surflets
|
||||
(define-structure surflets/surflet-sxml surflets/surflet-sxml-interface
|
||||
(open scheme-with-scsh ;error,receive
|
||||
(subset surflets/my-input-fields (input-field-html-tree))
|
||||
(subset surflets/internal-input-fields
|
||||
(*input-field-trigger*
|
||||
make-sxml-input-field))
|
||||
surflets/utilities
|
||||
(subset srfi-1 (make-list))
|
||||
surflets/sxml)
|
||||
(files surflet-sxml))
|
||||
|
||||
|
||||
;; Access to session-id and continuation-id
|
||||
(define-structure surflets/ids surflets/ids-interface
|
||||
(open scheme
|
||||
(subset surflet-requests (surflet-request-url))
|
||||
(subset srfi-1 (last))
|
||||
(subset surflet-handler/admin
|
||||
(instance-session-id
|
||||
resume-url-session-id
|
||||
resume-url-continuation-id
|
||||
resume-url-ids))
|
||||
(subset url (http-url-path)))
|
||||
(files ids))
|
||||
|
||||
|
||||
;; Some utilities
|
||||
(define-structure surflets/utilities surflets/utilities-interface
|
||||
(open scheme
|
||||
parse-html-forms)
|
||||
(files utilities))
|
||||
|
||||
|
||||
;; Intelligent Addresses
|
||||
(define-structure surflets/addresses surflets/addresses-interface
|
||||
(open scheme
|
||||
srfi-23 ;error
|
||||
(subset uri (escape-uri))
|
||||
define-record-types
|
||||
(subset surflets/utilities (generate-unique-name)))
|
||||
(files addresses))
|
||||
|
||||
(define-structure surflets/callbacks surflets/callbacks-interface
|
||||
(open scheme
|
||||
srfi-23 ;error
|
||||
surflets/addresses
|
||||
(subset surflet-handler/primitives (send/suspend))
|
||||
surflets/bindings
|
||||
surflets/returned-via)
|
||||
(files callbacks))
|
||||
|
||||
(define-structure surflets/returned-via surflets/returned-via-interface
|
||||
(open scheme
|
||||
surflets/input-field-value
|
||||
surflets/addresses
|
||||
(subset uri (unescape-uri)))
|
||||
(files returned-via))
|
||||
|
||||
(define-structure surflets/outdaters surflets/outdaters-interface
|
||||
(open scheme
|
||||
define-record-types
|
||||
surflets/send-html)
|
||||
(files outdater))
|
||||
|
||||
(define-structure surflets/bindings surflets/bindings-interface
|
||||
(open scheme-with-scsh ;read-string,error
|
||||
locks
|
||||
weak ;weak pointers
|
||||
surflets/utilities ;form-query-list
|
||||
surflet-requests
|
||||
(subset url (http-url-search))
|
||||
(subset srfi-14 (char-set:digit))
|
||||
(subset srfi-13 (string-index string-trim))
|
||||
(subset srfi-1 (filter))
|
||||
(subset sunet-utilities (get-header)))
|
||||
(files bindings))
|
||||
|
||||
(define-structures
|
||||
((surflets/send-html surflets/send-html-interface)
|
||||
(surflets/send-html-string surflets/send-html-string-interface))
|
||||
(open scheme
|
||||
surflet-handler/primitives
|
||||
surflets/sxml
|
||||
surflets/surflet-sxml)
|
||||
(files send-html))
|
||||
|
||||
(define-structure with-locks with-locks-interface
|
||||
(open scheme
|
||||
locks)
|
||||
(files with-locks))
|
||||
|
||||
;;; EOF
|
||||
;;; Local Variables:
|
||||
;;; buffer-tag-table: "../../../TAGS"
|
||||
;;; End::
|
||||
|
|
|
|||
|
|
@ -1,47 +0,0 @@
|
|||
|
||||
(define (returned-via return-object bindings)
|
||||
(if (input-field? return-object)
|
||||
(input-field-value return-object bindings)
|
||||
;; We assume we have a return-address-object instead.
|
||||
(let ((address (return-object 'address)))
|
||||
(cond
|
||||
((assoc (address-name address) bindings) =>
|
||||
(lambda (pair)
|
||||
(if (address-annotated? address)
|
||||
(address-annotation address (cdr pair))
|
||||
#t)))
|
||||
(else #f)))))
|
||||
|
||||
;; It depends on the object, if returned-via returns only boolean
|
||||
;; values or string values as well. So let us have both names.
|
||||
(define returned-via? returned-via)
|
||||
|
||||
;; This is from Martin Gasbichler
|
||||
(define-syntax case-returned-via
|
||||
(syntax-rules (else =>)
|
||||
((case-returned-via (%bindings ...) clauses ...)
|
||||
(let ((bindings (%bindings ...)))
|
||||
(case-returned-via bindings clauses ...)))
|
||||
((case-returned-via bindings (else body ...))
|
||||
(begin body ...))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) => %proc))
|
||||
(cond ((or (returned-via %return-object bindings) ...)
|
||||
=> %proc)))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) %body ...))
|
||||
(if (or (returned-via? %return-object bindings) ...)
|
||||
(begin %body ...)))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) => %proc)
|
||||
%clause %clauses ...)
|
||||
(cond ((or (returned-via %return-object bindings) ...)
|
||||
=> %proc)
|
||||
(else
|
||||
(case-returned-via bindings %clause %clauses ...))))
|
||||
((case-returned-via bindings
|
||||
((%return-object ...) %body ...)
|
||||
%clause %clauses ...)
|
||||
(if (or (returned-via? %return-object bindings) ...)
|
||||
(begin %body ...)
|
||||
(case-returned-via bindings %clause %clauses ...)))))
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
;; rt-module.scm
|
||||
;; Copyright Martin Gasbichler, 2002
|
||||
|
||||
;; Receipt:
|
||||
;;(load-config-file "test.scm") --> nothing
|
||||
;; load config file containing structure definition
|
||||
;;
|
||||
;; (reify-structure 'surflet) --> #{Rt-stucture surflet}
|
||||
;; gets structure info about a structure
|
||||
;;
|
||||
;; (define surflet ##)
|
||||
;; (load-structure surflet)
|
||||
;; loads rt-structure
|
||||
;;
|
||||
;; (rt-structure-binding surflet 'main) --> value
|
||||
;; get a binding of a structure
|
||||
|
||||
|
||||
(define (interface-value-names interface-name)
|
||||
(let ((interface (environment-ref (config-package) interface-name))
|
||||
(value-names '()))
|
||||
(for-each-declaration
|
||||
(lambda (name base-neme type)
|
||||
(if (not (equal? type syntax-type))
|
||||
(set! value-names (cons name value-names))))
|
||||
interface)
|
||||
value-names))
|
||||
|
||||
(define-record-type rt-structure :rt-structure
|
||||
(make-rt-structure meta-structure)
|
||||
rt-structure?
|
||||
(meta-structure rt-structure-meta-structure))
|
||||
|
||||
(define (rt-structure-loaded? rt-structure)
|
||||
(package-loaded?
|
||||
(structure-package (rt-structure-meta-structure rt-structure))))
|
||||
|
||||
(define-record-discloser :rt-structure
|
||||
(lambda (s)
|
||||
(list 'rt-stucture (structure-name (rt-structure-meta-structure s)))))
|
||||
|
||||
(define (reify-structure name)
|
||||
(let ((struct (get-structure name)))
|
||||
(make-rt-structure struct)))
|
||||
|
||||
(define (load-structure rts)
|
||||
(ensure-loaded (rt-structure-meta-structure rts)))
|
||||
|
||||
(define (rt-structure-binding structure name)
|
||||
(if (not (rt-structure-loaded? structure))
|
||||
(error "Structure not loaded" structure))
|
||||
(contents
|
||||
(binding-place
|
||||
(generic-lookup (rt-structure-meta-structure structure)
|
||||
name))))
|
||||
|
||||
(define (load-config-file file)
|
||||
(load file (config-package)))
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
;;; Allows sending of HTML represented in Oleg-like SXML-list instead
|
||||
;;; of pure string.
|
||||
;;; Copyright 2002,2003, Andreas Bernauer
|
||||
|
||||
|
||||
;; Send surflet-sxml lists as HTML
|
||||
(define (send-html/suspend html-tree-maker)
|
||||
(send/suspend
|
||||
(lambda (new-url)
|
||||
(make-usual-html-response
|
||||
(sxml->string (html-tree-maker new-url)
|
||||
surflet-sxml-rules)))))
|
||||
|
||||
(define (send-html/finish html-tree)
|
||||
(do-html-sending send/finish html-tree))
|
||||
|
||||
(define (send-html html-tree)
|
||||
(do-html-sending send html-tree))
|
||||
|
||||
;; Semd strings as HTML
|
||||
(define (send-html-string/suspend html-string-maker)
|
||||
(send/suspend
|
||||
(lambda (new-url)
|
||||
(make-usual-html-response
|
||||
(html-string-maker new-url)))))
|
||||
|
||||
(define (send-html-string/finish html-string)
|
||||
(do-html-string-sending send/finish html-string))
|
||||
|
||||
(define (send-html-string html-string)
|
||||
(do-html-string-sending send html-string))
|
||||
|
||||
;; Helping functions
|
||||
(define (do-html-sending sender html-tree)
|
||||
(do-html-string-sending
|
||||
sender
|
||||
(sxml->string html-tree surflet-sxml-rules)))
|
||||
|
||||
(define (do-html-string-sending sender html-string)
|
||||
(sender (make-usual-html-response html-string)))
|
||||
|
||||
;; This is not for public, as we add the no-cache header that is
|
||||
;; needed for SUrflets.
|
||||
(define (make-usual-html-response html-string)
|
||||
(make-surflet-response
|
||||
(status-code ok)
|
||||
"text/html"
|
||||
'(("Cache-Control" . "no-cache"))
|
||||
html-string))
|
||||
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
(define processing-instruction-rule
|
||||
`(*PI* *preorder*
|
||||
. ,(lambda (tag . elems)
|
||||
`(,(string-append "<?" (symbol->string (car elems)) " ")
|
||||
,@(cdr elems)
|
||||
"?>"))))
|
||||
|
||||
(define doctype-rule
|
||||
`(*DOCTYPE* *preorder*
|
||||
. ,(lambda (content . more)
|
||||
`("<!DOCTYPE " ,@more ">"))))
|
||||
|
||||
(define xml-default-rule
|
||||
`(*default* .
|
||||
,(lambda (tag . elems)
|
||||
(apply (entag tag) elems))))
|
||||
|
||||
(define (entag tag)
|
||||
(lambda elems
|
||||
(if (and (pair? elems) (pair? (car elems)) (eq? '@ (caar elems)))
|
||||
(list #\< tag (cdar elems)
|
||||
(if (pair? (cdr elems)) (list #\> (cdr elems) "</" tag #\>)
|
||||
"/>"))
|
||||
(list #\< tag
|
||||
(if (pair? elems) (list #\> elems "</" tag #\>) "/>")))))
|
||||
|
||||
(define comment-rule
|
||||
`(*COMMENT* *preorder*
|
||||
. ,(lambda (tag . elems)
|
||||
`("<!-- " ,@elems "-->"))))
|
||||
|
||||
(define xml-rules
|
||||
(list attribute-rule
|
||||
xml-default-rule
|
||||
processing-instruction-rule
|
||||
doctype-rule
|
||||
text-rule
|
||||
comment-rule
|
||||
url-rule
|
||||
plain-html-rule
|
||||
nbsp-rule))
|
||||
|
||||
(define (make-xml-reponse xml-string)
|
||||
(make-surflet-response
|
||||
(status-code ok)
|
||||
"text/xml"
|
||||
'(("Cache-Control" . "no-cache"))
|
||||
xml-string))
|
||||
|
||||
(define (send-xml/suspend xml-tree-maker)
|
||||
(send/suspend
|
||||
(lambda (k-url)
|
||||
(make-xml-reponse
|
||||
(sxml->string (xml-tree-maker k-url)
|
||||
xml-rules)))))
|
||||
|
||||
(define (send-xml/finish xml-tree)
|
||||
(send
|
||||
(make-xml-reponse
|
||||
(sxml->string xml-tree xml-rules))))
|
||||
|
|
@ -66,7 +66,7 @@
|
|||
(br)
|
||||
(p ,@text)
|
||||
(br)
|
||||
(url ,url "Continue"))))))
|
||||
(URL ,url "Continue"))))))
|
||||
|
||||
;; Post some information on a Web page, shut down the surflet and all
|
||||
;; its continuations.
|
||||
|
|
@ -116,16 +116,16 @@
|
|||
(else (no-method message)))))
|
||||
|
||||
(define (make-text text)
|
||||
(standard-query text (make-text-field) "No bad input possible"))
|
||||
(standard-query text (make-text-input-field) "No bad input possible"))
|
||||
|
||||
(define (make-password text)
|
||||
(standard-query text (make-password-field) "No bad input possible"))
|
||||
(standard-query text (make-password-input-field) "No bad input possible"))
|
||||
|
||||
(define (make-number text)
|
||||
(standard-query text (make-number-field) "Please respond with a valid number"))
|
||||
(standard-query text (make-number-input-field) "Please respond with a valid number"))
|
||||
|
||||
(define (make-boolean text)
|
||||
(let* ((input-field (make-checkbox))
|
||||
(let* ((input-field (make-checkbox-input-field))
|
||||
(standard (standard-query text input-field "No bad input possible")))
|
||||
(lambda (message)
|
||||
(case message
|
||||
|
|
@ -139,7 +139,7 @@
|
|||
|
||||
(define (make-radio text choices . maybe-insist)
|
||||
(let* ((insist (:optional maybe-insist ""))
|
||||
(radios (make-radios choices))
|
||||
(radios (make-radio-input-fields choices))
|
||||
(standard (standard-query text (car radios)
|
||||
(string-append "Please respond" insist))))
|
||||
(lambda (message)
|
||||
|
|
@ -150,9 +150,7 @@
|
|||
`(tr (td ,text)
|
||||
(td (table (tr
|
||||
,@(map (lambda (radio choice)
|
||||
`((td ,radio ,choice
|
||||
;; Add some distance
|
||||
(nbsp)(nbsp))))
|
||||
`((td ,radio) (td ,choice)))
|
||||
radios
|
||||
choices)))))))
|
||||
(else
|
||||
|
|
|
|||
|
|
@ -0,0 +1,210 @@
|
|||
#!/bin/sh
|
||||
echo "Loading..."
|
||||
fullpath=`which $0`
|
||||
# $sunet is either $SUNETHOME or created out of fullpath
|
||||
# Kind of a hack, I know.
|
||||
sunet=${SUNETHOME:-`dirname $fullpath`/../..}
|
||||
ssax=${SSAXPATH:-$sunet/SSAX} # path to SSAX
|
||||
|
||||
exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/surflets/packages.scm -dm -o surflet-server -e main -s "$0" "$@"
|
||||
!#
|
||||
|
||||
(define-structure surflet-server
|
||||
(export main ; sh jump entry point
|
||||
server) ; scsh entry point
|
||||
(open httpd-core
|
||||
httpd-make-options
|
||||
httpd-basic-handlers
|
||||
httpd-file-directory-handlers
|
||||
; cgi-server
|
||||
; seval-handler
|
||||
; rman-gateway
|
||||
; info-gateway
|
||||
surflet-handler
|
||||
let-opt
|
||||
scsh
|
||||
scheme)
|
||||
|
||||
(begin
|
||||
|
||||
(define (usage)
|
||||
(format #f
|
||||
"Usage: start-surflet-server [-h htdocs-dir] [-s surflet-dir] [-i images-dir]
|
||||
[-p port] [-l log-file-name]
|
||||
[-r requests] [--help]
|
||||
|
||||
with
|
||||
htdocs-dir directory of html files (default: ./web-server/root/htdocs)
|
||||
surflet-dir directory of SUrflet files (default: ./web-server/root/surflets)
|
||||
images-dir directory of images files (default: ./web-server/root/img)
|
||||
port port server is listening to (default: 8080)
|
||||
log-file-name directory where to store the logfile in CLF
|
||||
(default: ./web-server/httpd.log)
|
||||
requests maximal amount of simultaneous requests (default 5)
|
||||
--help show this help
|
||||
|
||||
NOTE: This is the SUrflet-server. It does not support cgi-bin.
|
||||
"
|
||||
))
|
||||
|
||||
(define htdocs-dir #f)
|
||||
(define images-dir #f)
|
||||
; (define cgi-bin-dir #f)
|
||||
(define port #f)
|
||||
(define log-file-name #f)
|
||||
(define root #f)
|
||||
(define surflet-dir #f)
|
||||
(define simultaneous-requests #f)
|
||||
|
||||
(define (init)
|
||||
(set! htdocs-dir "./web-server/root/htdocs")
|
||||
(set! images-dir "./web-server/root/img")
|
||||
; (set! cgi-bin-dir "./web-server/root/cgi-bin")
|
||||
(set! port "8088")
|
||||
(set! log-file-name "./web-server/httpd.log")
|
||||
(set! root "./web-server/root")
|
||||
(set! surflet-dir "./web-server/root/surflets")
|
||||
(set! simultaneous-requests "5"))
|
||||
|
||||
(define (normalize-options)
|
||||
(set! htdocs-dir (absolute-file-name htdocs-dir))
|
||||
(set! images-dir (absolute-file-name images-dir))
|
||||
(set! log-file-name (absolute-file-name log-file-name))
|
||||
; (set! cgi-bin-dir (absolute-file-name cgi-bin-dir))
|
||||
(set! port (string->number port))
|
||||
(set! surflet-dir (absolute-file-name surflet-dir))
|
||||
(set! simultaneous-requests (string->number simultaneous-requests)))
|
||||
|
||||
(define get-options
|
||||
(let* ((unknown-option-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"unknown option `~A'~%try `surflet-server --help'~%"
|
||||
option)
|
||||
(exit 1)))
|
||||
(missing-argument-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"option `~A' requires an argument~%try `surflet-server --help'~%"
|
||||
option)
|
||||
(exit 1))))
|
||||
(lambda (options)
|
||||
(let loop ((options options))
|
||||
(if (null? options)
|
||||
(normalize-options)
|
||||
(cond
|
||||
((string=? (car options) "-h")
|
||||
(if (null? (cdr options))
|
||||
(missing-argument-error (car options))
|
||||
(set! htdocs-dir (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "-i")
|
||||
(if (null? (cdr options))
|
||||
(missing-argument-error (car options))
|
||||
(set! images-dir (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "-c")
|
||||
(format (error-output-port)
|
||||
"This is the SUrflet server. It does not support cgi.~%")
|
||||
; (if (null? (cdr options))
|
||||
; (missing-argument-error (car options))
|
||||
; (set! cgi-bin-dir (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "-p")
|
||||
(if (null? (cdr options))
|
||||
(missing-argument-error (car options))
|
||||
(set! port (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "-l")
|
||||
(if (null? (cdr options))
|
||||
(missing-argument-error (car options))
|
||||
(set! log-file-name (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "-s")
|
||||
(if (null? (cdr options))
|
||||
(missing-argument-error (car options))
|
||||
(set! surflet-dir (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "-r")
|
||||
(if (null? (cdr options))
|
||||
(missing-argument-error (car options))
|
||||
(set! simultaneous-requests (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "--help")
|
||||
(display (usage))
|
||||
(exit 0))
|
||||
((string=? (car options) "--dump")
|
||||
(let ((image-name (if (null? (cdr options))
|
||||
"surflet-server"
|
||||
(cadr options))))
|
||||
(dump-scsh-program main image-name))
|
||||
(exit 0))
|
||||
(else
|
||||
(unknown-option-error (car options)))))))))
|
||||
|
||||
(define (server . args)
|
||||
(if (pair? args)
|
||||
(main `(main ,@(car args)))
|
||||
(main '(main))))
|
||||
|
||||
(define (main args)
|
||||
(init)
|
||||
(format #t "reading options: ~s~%" (cdr args))
|
||||
(get-options (cdr args))
|
||||
(cond ((zero? (user-uid))
|
||||
(set-gid (->gid "nobody"))
|
||||
(set-uid (->uid "nobody"))))
|
||||
|
||||
(format #t "Going to run SUrflet server with:
|
||||
htdocs-dir: ~a
|
||||
surflet-dir: ~a
|
||||
images-dir: ~a
|
||||
port: ~a
|
||||
log-file-name: ~a
|
||||
a maximum of ~a simultaneous requests, syslogging activated,
|
||||
and home-dir-handler (public_html) activated.
|
||||
|
||||
NOTE: This is the SUrflet server. It does not support cgi.
|
||||
"
|
||||
htdocs-dir
|
||||
surflet-dir
|
||||
images-dir
|
||||
port
|
||||
log-file-name
|
||||
simultaneous-requests)
|
||||
|
||||
(httpd (with-port port
|
||||
(with-root-directory (cwd)
|
||||
(with-simultaneous-requests simultaneous-requests
|
||||
(with-syslog? #t
|
||||
(with-logfile log-file-name
|
||||
;; The following settings are made to avoid dns lookups.
|
||||
(with-reported-port port
|
||||
(with-fqdn "localhost"
|
||||
(with-resolve-ips? #f
|
||||
(with-request-handler
|
||||
(alist-path-dispatcher
|
||||
(list (cons "h" (home-dir-handler "public_html"))
|
||||
; (cons "seval" seval-handler)
|
||||
; (cons "man" (rman-handler #f "man?%s(%s)"
|
||||
; "Generated by rman-gateway"))
|
||||
; (cons "info" (info-handler #f #f #f
|
||||
; "Generated by info-gateway"))
|
||||
; (cons "cgi-bin" (cgi-handler cgi-bin-dir))
|
||||
;; Browsers cannot handle .SCM files: Opera shows
|
||||
;; it as HTML, Netscape asks for a program to
|
||||
;; view it. ROOTED-FILE-OR-DIRECTORY-HANDLER
|
||||
;; should serve .SCM files as text/plain (I did
|
||||
;; not want to write a handler just for this file
|
||||
;; type.)
|
||||
(cons "source" (rooted-file-or-directory-handler surflet-dir))
|
||||
(cons "img" (rooted-file-handler images-dir))
|
||||
(cons "surflet" (surflet-handler surflet-dir)))
|
||||
(rooted-file-or-directory-handler htdocs-dir)))))))))))
|
||||
))
|
||||
))
|
||||
;; EOF
|
||||
|
||||
;;; Local Variables:
|
||||
;;; mode:scheme
|
||||
;;; End:
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,509 +0,0 @@
|
|||
;;; SUrflets' input fields
|
||||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
;;; With additions from Eric Knauel (2003)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Functions to create simple input fields
|
||||
|
||||
;; The interface for input-fields does not prescribe what the type of
|
||||
;; attributes has to be. We choose a record here.
|
||||
|
||||
(define-record-type field-attributes :field-attributes
|
||||
(make-field-attributes default others)
|
||||
field-attributes?
|
||||
(default field-attributes-default set-field-attributes-default!)
|
||||
(others field-attributes-others set-field-attributes-others!))
|
||||
|
||||
;; A simple input-field is a prototype for other input-fields.
|
||||
;; REPORTED-TYPE is the type of the input-field in HTML, TYPE the
|
||||
;; internal referenced type and TRANSFORMER the function that
|
||||
;; translates the HTTP-string of the request into a scheme value.
|
||||
(define (simple-field-maker reported-type type default-pred transformer)
|
||||
(lambda maybe-further-attributes
|
||||
(let ((name (generate-input-field-name type)))
|
||||
(let-optionals maybe-further-attributes
|
||||
((default "" default-pred)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-input-field name type
|
||||
transformer
|
||||
(make-field-attributes
|
||||
(and default `(value ,default))
|
||||
(sxml-attribute-attributes attributes))
|
||||
(simple-html-tree-maker reported-type))))))
|
||||
|
||||
(define (simple-html-tree-maker reported-type)
|
||||
(lambda (input-field)
|
||||
(let ((attributes (input-field-attributes input-field)))
|
||||
`(input (@ (type ,reported-type)
|
||||
(name ,(input-field-name input-field))
|
||||
,(field-attributes-default attributes)
|
||||
,(field-attributes-others attributes))))))
|
||||
|
||||
(define (make-simple-default-setter default-pred? error-msg-types)
|
||||
(lambda (input-field value)
|
||||
(if (default-pred? value)
|
||||
(set-field-attributes-default!
|
||||
(input-field-attributes input-field)
|
||||
`(value ,value))
|
||||
(error (format #f "Default value must be ~a." error-msg-types)
|
||||
value))
|
||||
(touch-input-field! input-field)))
|
||||
|
||||
(define (string-or-symbol? thing)
|
||||
(or (string? thing) (symbol? thing)))
|
||||
(define simple-default? string-or-symbol?)
|
||||
|
||||
(define set-simple-field-default!
|
||||
(make-simple-default-setter simple-default? "a string or a symbol"))
|
||||
|
||||
(define (second-arg first second) second)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Text input field
|
||||
(define make-text-field
|
||||
(simple-field-maker "text" "text" simple-default? second-arg))
|
||||
(define set-text-field-value! set-simple-field-default!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Number input field
|
||||
(define (number-field-default? value)
|
||||
(or (number? value)
|
||||
(simple-default? value)))
|
||||
(define (number-field-transformer input-field string)
|
||||
(or (string->number string)
|
||||
(error "wrong type")))
|
||||
(define make-number-field
|
||||
(simple-field-maker "text" "number"
|
||||
number-field-default? number-field-transformer))
|
||||
(define set-number-field-value!
|
||||
(make-simple-default-setter number-field-default?
|
||||
"a number a string or a symbol"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; hidden input-field
|
||||
;; The programmer should supply a default value for this input-field
|
||||
;; as it is hidden.
|
||||
(define make-hidden-field
|
||||
(simple-field-maker "hidden" "hidden"
|
||||
simple-default? second-arg))
|
||||
(define set-hidden-field-value! set-simple-field-default!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Password input field
|
||||
(define make-password-field
|
||||
(simple-field-maker "password" "password"
|
||||
simple-default? second-arg))
|
||||
(define set-password-field-value! set-simple-field-default!)
|
||||
|
||||
;;; That's it for simple input fields.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Textarea input field
|
||||
(define (make-textarea . maybe-further-attributes)
|
||||
(let-optionals maybe-further-attributes
|
||||
((default-text "" simple-default?)
|
||||
(rows 5 number?)
|
||||
(cols 20 number?)
|
||||
(readonly #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(let ((name (generate-input-field-name "textarea"))
|
||||
(all-attributes `((cols ,cols)
|
||||
(rows ,rows)
|
||||
,@(if readonly '(readonly) '())
|
||||
,@(sxml-attribute-attributes attributes))))
|
||||
(make-input-field
|
||||
name "textarea"
|
||||
second-arg
|
||||
(make-field-attributes (and default-text)
|
||||
all-attributes)
|
||||
make-textarea-html-tree))))
|
||||
|
||||
(define (make-textarea-html-tree textarea)
|
||||
(let ((attributes (input-field-attributes textarea)))
|
||||
`(textarea (@ (type "textarea")
|
||||
(name ,(input-field-name textarea))
|
||||
,(field-attributes-others attributes))
|
||||
,(field-attributes-default attributes))))
|
||||
|
||||
(define (set-textarea-value! textarea value)
|
||||
(if (simple-default? value)
|
||||
(set-field-attributes-default!
|
||||
(input-field-attributes textarea)
|
||||
value)
|
||||
(error "Default value must be a string or a symbol." value))
|
||||
(touch-input-field! textarea))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Select input field
|
||||
|
||||
;(make-select '("this" "that" "those") '(@ ((id "sushi"))))
|
||||
;(make-select '("this" ("that" '(@ (selected))) "those"))
|
||||
;; dropdown: (size 1)
|
||||
|
||||
;;; A select input field shows a list of options that can be
|
||||
;;; selected. For this purpose, we introduce an select-option record,
|
||||
;;; that contains all the information for each option. This is
|
||||
;;; justified by the fact, that the options list is seperated in HTML,
|
||||
;;; too. The TAG is the string that is displayed in the website, the
|
||||
;;; VALUE is the value that is returned by input-field-value, if this
|
||||
;;; option was selected. TAG is assumed to be unique by some functions
|
||||
;;; (e.g. select and unselect) SELECTED? tells us, if this option is
|
||||
;;; preselected.
|
||||
(define-record-type select-option :select-option
|
||||
(really-make-select-option tag value selected? attributes)
|
||||
select-option?
|
||||
(tag select-option-tag)
|
||||
(value select-option-value)
|
||||
(selected? select-option-selected? really-set-select-option-selected?!)
|
||||
(attributes select-option-attributes set-select-option-attributes!))
|
||||
|
||||
;; No check of attributes as this is done by calling function. (This
|
||||
;; function isn't exported.
|
||||
(define (make-select-option tag value selected? attributes)
|
||||
(if (string? tag)
|
||||
(really-make-select-option tag value selected?
|
||||
(sxml-attribute-attributes attributes))
|
||||
(error "Select-option's tag must be a string." tag)))
|
||||
|
||||
;; Constructor for valued select input-field option.
|
||||
(define (make-annotated-select-option tag value . maybe-attributes)
|
||||
(let-optionals maybe-attributes
|
||||
((selected? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-select-option tag value selected? attributes)))
|
||||
|
||||
;; Constructor for a simple select input-field option (not annotated).
|
||||
(define (make-simple-select-option tag . maybe-attributes)
|
||||
(let-optionals maybe-attributes
|
||||
((selected? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-select-option tag tag selected? attributes)))
|
||||
|
||||
(define-record-discloser :select-option
|
||||
(lambda (select-option)
|
||||
(list 'select-option
|
||||
(select-option-tag select-option)
|
||||
(select-option-value select-option)
|
||||
(select-option-selected? select-option)
|
||||
(select-option-attributes select-option)
|
||||
)))
|
||||
|
||||
;; Selecting / Unselecting of an option in an select input-field,
|
||||
;; chosen by tag.
|
||||
(define (select-select-option! tag select)
|
||||
(set-select-option-selected?! tag select #t))
|
||||
|
||||
(define (unselect-select-option! tag select)
|
||||
(set-select-option-selected?! tag select #f))
|
||||
|
||||
(define (set-select-option-selected?! tag select selected?)
|
||||
(let ((options (field-attributes-default
|
||||
(input-field-attributes select))))
|
||||
(if (number? tag) ; is tag an index?
|
||||
(really-set-select-option-selected?! (list-ref options tag)
|
||||
selected?)
|
||||
(let lp ((options options))
|
||||
(if (null? options)
|
||||
(error "No such option" tag select)
|
||||
(if (tag=select-option? tag (car options))
|
||||
(really-set-select-option-selected?! (car options)
|
||||
selected?)
|
||||
(lp (cdr options))))))
|
||||
(touch-input-field! select)))
|
||||
|
||||
;; Find select-option in a list by its tag.
|
||||
(define (tag=select-option? tag select-option)
|
||||
(string=? tag (select-option-tag select-option)))
|
||||
|
||||
(define (find-select-option tag select-options)
|
||||
(cond ((member/srfi-1 tag select-options tag=select-option?)
|
||||
=> car)
|
||||
;; MEMBER/SRFI-1 returns the sublist that starts with the
|
||||
;; searched element.
|
||||
(else #f)))
|
||||
|
||||
(define (find-select-option-value tag select-options)
|
||||
(cond ((find-select-option tag select-options)
|
||||
=> select-option-value)
|
||||
(else #f)))
|
||||
|
||||
(define (add-select-option! select select-option)
|
||||
(let ((attributes (input-field-attributes select)))
|
||||
(set-field-attributes-default!
|
||||
attributes
|
||||
(cons select-option
|
||||
(field-attributes-default attributes)))
|
||||
(touch-input-field! select)))
|
||||
|
||||
(define (delete-select-option! select select-option)
|
||||
(let* ((attributes (input-field-attributes select))
|
||||
(select-options (field-attributes-default attributes)))
|
||||
(if (select-option? select-option)
|
||||
(set-field-attributes-default!
|
||||
attributes
|
||||
(delete select-option select-options))
|
||||
(let ((tag select-option))
|
||||
(set-field-attributes-default!
|
||||
attributes
|
||||
(delete tag select-options tag=select-option?))))
|
||||
(touch-input-field! select)))
|
||||
|
||||
;; To be compatible with previous versions of MAKE-SELECT-INPUT-FIELD,
|
||||
;; we accept also a simple list as an option-list. New programs should
|
||||
;; use select-options-list (easily createable with
|
||||
;; (map make-simple-select-option option-list))
|
||||
(define (simple-options select-options)
|
||||
(if (and (list? select-options)
|
||||
(every select-option? select-options))
|
||||
select-options
|
||||
(map make-simple-select-option select-options)))
|
||||
|
||||
(define (make-select select-options . maybe-further-attributes)
|
||||
(let ((real-select-options (simple-options select-options)))
|
||||
(let-optionals maybe-further-attributes
|
||||
((multiple? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(let ((name (generate-input-field-name "select")))
|
||||
(if multiple?
|
||||
(make-multiple-select name real-select-options attributes)
|
||||
(make-single-select name real-select-options
|
||||
attributes))))))
|
||||
|
||||
;; deprecated: Does not introduce further functionality.
|
||||
(define make-annotated-select make-select)
|
||||
|
||||
;; internal
|
||||
(define (make-multiple-select name select-options attributes)
|
||||
(make-multi-input-field name "mult-select"
|
||||
multiple-select-transformer
|
||||
(make-field-attributes
|
||||
select-options
|
||||
`((multiple)
|
||||
,@(sxml-attribute-attributes attributes)))
|
||||
make-select-html-tree))
|
||||
|
||||
;; internal
|
||||
(define (make-single-select name select-options attributes)
|
||||
(make-input-field name "select"
|
||||
(lambda (input-field tag)
|
||||
(cond ((find-select-option-value tag select-options)
|
||||
=> identity)
|
||||
(else (error "no such option." tag))))
|
||||
(make-field-attributes
|
||||
select-options
|
||||
(sxml-attribute-attributes attributes))
|
||||
make-select-html-tree))
|
||||
|
||||
(define (multiple-select-transformer select bindings)
|
||||
(let ((name (input-field-name select))
|
||||
(select-options (field-attributes-default
|
||||
(input-field-attributes select))))
|
||||
(let* ((my-bindings (filter (lambda (binding)
|
||||
(equal? (car binding) name))
|
||||
bindings))
|
||||
(tags (map cdr my-bindings)))
|
||||
(filter-map (lambda (tag)
|
||||
(find-select-option-value tag select-options))
|
||||
tags))))
|
||||
|
||||
(define (make-select-html-tree select)
|
||||
(let ((attributes (input-field-attributes select)))
|
||||
`(select (@ (name ,(input-field-name select))
|
||||
,(field-attributes-others attributes))
|
||||
#\newline
|
||||
,@(make-select-options-html-tree
|
||||
(field-attributes-default attributes)))))
|
||||
|
||||
(define (make-select-options-html-tree select-options)
|
||||
(map (lambda (select-option)
|
||||
`(option (@ ,(and (select-option-selected? select-option) '(selected))
|
||||
,(select-option-attributes select-option))
|
||||
,(select-option-tag select-option)))
|
||||
select-options))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; radio input-fields
|
||||
;; Because grouped radio input-fields must use the same name, we
|
||||
;; cannot just return one radio input-field object, but we must
|
||||
;; generate several ones with the same name.
|
||||
(define (make-radio-group)
|
||||
(let ((name (generate-input-field-name "radio")))
|
||||
(lambda (value-string . maybe-further-attributes)
|
||||
(let-optionals maybe-further-attributes
|
||||
((checked? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-input-field name "radio"
|
||||
second-arg
|
||||
(make-field-attributes
|
||||
(and checked? '(checked))
|
||||
`((value ,value-string)
|
||||
,@(sxml-attribute-attributes attributes)))
|
||||
radio-html-tree-maker)))))
|
||||
|
||||
(define (make-annotated-radio-group)
|
||||
(let* ((name (generate-input-field-name "radio"))
|
||||
(value-table (make-integer-table))
|
||||
(transformer (make-radio-transformer value-table)))
|
||||
(lambda (value . maybe-further-attributes)
|
||||
(let-optionals maybe-further-attributes
|
||||
((checked? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(let ((number (generate-unique-number)))
|
||||
(table-set! value-table number value)
|
||||
(make-input-field name "radio"
|
||||
transformer
|
||||
(make-field-attributes
|
||||
(and checked? '(checked))
|
||||
`((value ,(number->string number))
|
||||
,@(sxml-attribute-attributes attributes)))
|
||||
radio-html-tree-maker))))))
|
||||
|
||||
(define (make-radios values . maybe-further-attributes)
|
||||
(let-optionals maybe-further-attributes
|
||||
((attributes '() sxml-attribute?))
|
||||
(let ((radio-gen (make-annotated-radio-group)))
|
||||
(map (lambda (value)
|
||||
(if attributes
|
||||
(radio-gen value attributes)
|
||||
(radio-gen value)))
|
||||
values))))
|
||||
|
||||
|
||||
(define (make-radio-transformer value-table)
|
||||
(lambda (input-field tag)
|
||||
(cond
|
||||
((string->number tag) =>
|
||||
(lambda (number)
|
||||
(let ((value (table-ref value-table number)))
|
||||
(if value
|
||||
value
|
||||
(error "Unknown tag number for radio input-field" tag)))))
|
||||
(else
|
||||
(error "Unknown tag number for radio input-field" tag)))))
|
||||
|
||||
(define (radio-html-tree-maker radio)
|
||||
(let* ((attributes (input-field-attributes radio)))
|
||||
`(input (@ ((type "radio")
|
||||
(name ,(input-field-name radio))
|
||||
,(field-attributes-default attributes)
|
||||
,(field-attributes-others attributes))))))
|
||||
|
||||
(define (set-input-field-checked?! input-field checked?)
|
||||
(let ((attributes (input-field-attributes input-field)))
|
||||
(set-field-attributes-default!
|
||||
attributes
|
||||
(if checked? '(checked) #f))
|
||||
(touch-input-field! input-field)))
|
||||
|
||||
(define set-radio-checked?! set-input-field-checked?!)
|
||||
(define (check-radio! radio) (set-radio-checked?! radio #t))
|
||||
(define (uncheck-radio! radio) (set-radio-checked?! radio #f))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; checkbox input-field
|
||||
(define (make-checkbox . maybe-further-attributes)
|
||||
(really-make-checkbox 'defined-in-checkbox-transformer
|
||||
checkbox-transformer
|
||||
maybe-further-attributes))
|
||||
|
||||
(define (make-annotated-checkbox value . maybe-further-attributes)
|
||||
(really-make-checkbox value
|
||||
(make-checkbox-transformer value)
|
||||
maybe-further-attributes))
|
||||
|
||||
(define (really-make-checkbox value transformer attributes)
|
||||
(let ((name (generate-input-field-name "checkbox")))
|
||||
(let-optionals attributes
|
||||
((checked? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-input-field name "checkbox"
|
||||
transformer
|
||||
(make-field-attributes
|
||||
(and checked? '(checked))
|
||||
(sxml-attribute-attributes attributes))
|
||||
checkbox-html-tree-maker))))
|
||||
|
||||
(define (make-checkbox-transformer value)
|
||||
(lambda (input-field tag)
|
||||
(if (string=? tag "on")
|
||||
value
|
||||
#f)))
|
||||
|
||||
(define checkbox-transformer (make-checkbox-transformer #t))
|
||||
|
||||
(define (checkbox-html-tree-maker checkbox)
|
||||
(let ((attributes (input-field-attributes checkbox)))
|
||||
`(input (@ ((type "checkbox")
|
||||
(name ,(input-field-name checkbox))
|
||||
,(field-attributes-default attributes)
|
||||
,(field-attributes-others attributes))))))
|
||||
|
||||
(define set-checkbox-checked?! set-input-field-checked?!)
|
||||
(define (check-checkbox! checkbox) (set-checkbox-checked?! checkbox #t))
|
||||
(define (uncheck-checkbox! checkbox) (set-checkbox-checked?! checkbox #f))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; button input-fields
|
||||
(define (make-button type name button-caption attributes)
|
||||
(make-input-field name type
|
||||
second-arg
|
||||
(make-field-attributes
|
||||
(and button-caption `(value ,button-caption))
|
||||
(sxml-attribute-attributes attributes))
|
||||
make-button-html-tree))
|
||||
|
||||
(define (make-button-html-tree button)
|
||||
(let ((attributes (input-field-attributes button)))
|
||||
`(input (@ (type ,(input-field-type button))
|
||||
(name ,(input-field-name button))
|
||||
,(field-attributes-default attributes)
|
||||
,(field-attributes-others attributes)))))
|
||||
|
||||
(define (make-submit-button . maybe-further-attributes)
|
||||
(let-optionals maybe-further-attributes
|
||||
((button-caption #f string?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-button "submit" (generate-input-field-name "submit")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-reset-button . maybe-further-attributes)
|
||||
(let-optionals maybe-further-attributes
|
||||
((button-caption #f string?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-button "reset" (generate-input-field-name "reset")
|
||||
button-caption attributes)))
|
||||
|
||||
;; Image buttons cannot be simple buttons, as the browser does not
|
||||
;; send their simple name, but the coordinates where the user clicked
|
||||
;; into. Thanks to Eric Knauel for reporting this bug.
|
||||
(define (make-image-button image-source . maybe-further-attributes)
|
||||
(let-optionals maybe-further-attributes
|
||||
((attributes '() sxml-attribute?))
|
||||
(make-multi-input-field (generate-input-field-name "imgbtn")
|
||||
"image"
|
||||
image-button-transformer
|
||||
(make-field-attributes
|
||||
`(src ,image-source)
|
||||
(sxml-attribute-attributes attributes))
|
||||
make-button-html-tree)))
|
||||
|
||||
;; The following two functions are from Eric Knauel's fix for the
|
||||
;; image-button bug:
|
||||
(define (image-button-transformer image-button bindings)
|
||||
(let ((x (find-image-button-coordinate image-button bindings ".x"))
|
||||
(y (find-image-button-coordinate image-button bindings ".y")))
|
||||
(let ((x-number (string->number x))
|
||||
(y-number (string->number y)))
|
||||
(and x y
|
||||
(if (and x-number y-number)
|
||||
(cons x-number y-number)
|
||||
(error "Image button coordinates aren't numbers. " x y))))))
|
||||
|
||||
(define (find-image-button-coordinate image-button bindings suffix)
|
||||
(let* ((name (input-field-name image-button)))
|
||||
(cond
|
||||
((assoc (string-append name suffix) bindings)
|
||||
=> cdr)
|
||||
(else #f))))
|
||||
|
||||
;;EOF
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
;; Copyright Andras Bernauer (2003)
|
||||
|
||||
;; somehow `extend' httpd-request
|
||||
(define-record-type surflet-request :surflet-request
|
||||
(make-surflet-request request input-port)
|
||||
surflet-request?
|
||||
(request surflet-request-request)
|
||||
(input-port surflet-request-input-port))
|
||||
|
||||
(define-record-discloser :surflet-request
|
||||
(lambda (r)
|
||||
(list 'surflet-request
|
||||
(surflet-request-request r))))
|
||||
|
||||
(define (make-fake-selector request-selector)
|
||||
(lambda (surflet-request)
|
||||
(request-selector (surflet-request-request surflet-request))))
|
||||
|
||||
(define surflet-request-method (make-fake-selector request-method))
|
||||
(define surflet-request-uri (make-fake-selector request-uri))
|
||||
(define surflet-request-url (make-fake-selector request-url))
|
||||
(define surflet-request-version (make-fake-selector request-version))
|
||||
(define surflet-request-headers (make-fake-selector request-headers))
|
||||
(define surflet-request-socket (make-fake-selector request-socket))
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
;;; SURFLET-RESPONSE: Surflets are expected to return this object type.
|
||||
;;; STATUS is the status code, an exact integer. See httpd/response.scm
|
||||
;;; e.g. (status-code ok)
|
||||
;;; CONTENT-TYPE is a string, most probably "text/html".
|
||||
;;; HEADERS is a (maybe empty) list of pairs of (string or symbol);
|
||||
;;; Additional headers to send, e.g. '(("Cache-Control" . "no-cache")) or
|
||||
;;; '((Cache-Control . "no-cache")) etc.
|
||||
;;; DATA is either
|
||||
;;; * a string
|
||||
;;; * a list of strings
|
||||
;;; This list maybe extended to vectors later.
|
||||
(define-record-type surflet-response :surflet-response
|
||||
(make-surflet-response status content-type headers data)
|
||||
surflet-response?
|
||||
(status surflet-response-status)
|
||||
(content-type surflet-response-content-type)
|
||||
(headers surflet-response-headers)
|
||||
(data surflet-response-data))
|
||||
|
||||
;; Allowed type for the data field.
|
||||
(define (valid-surflet-response-data? data)
|
||||
(or (string? data) (list? data)))
|
||||
|
||||
;; For debug purposes
|
||||
(define (surflet-response->string surflet-response)
|
||||
(format #f "#{SUrflet-response Status: ~a Content-Type: ~s Headers: ~s~%~s~%"
|
||||
(surflet-response-status surflet-response)
|
||||
(surflet-response-content-type surflet-response)
|
||||
(surflet-response-headers surflet-response)
|
||||
(surflet-response-data surflet-response)))
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue