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

Compare commits

merge into: scsh-conservatory:http-1-1-bp
Branches Tags
scsh-conservatory:main
scsh-conservatory:http-1-1
scsh-conservatory:http-1-1-bp
scsh-conservatory:surflet-send-suspend-with-port
scsh-conservatory:servlets
scsh-conservatory:rel-1-1-fixes
scsh-conservatory:thread-support
scsh-conservatory:import-1.1.1
...
pull from: scsh-conservatory:main
Branches Tags
scsh-conservatory:main
scsh-conservatory:http-1-1
scsh-conservatory:http-1-1-bp
scsh-conservatory:surflet-send-suspend-with-port
scsh-conservatory:servlets
scsh-conservatory:rel-1-1-fixes
scsh-conservatory:thread-support
scsh-conservatory:import-1.1.1

66 Commits
http-1-1-b ... main

Author SHA1 Message Date
sperber 5ba7f23259 `set-ftp-socket-options!' may fail; move it to a place where proper 
error handling is in place.
 2009-09-21 08:11:08 +00:00
nofreude 1e320f445c initial release for dnsd. 2006-11-12 18:21:33 +00:00
nofreude 50df77a8a8 initial release for dnsd. 2006-11-12 18:15:12 +00:00
nofreude 4b9a16653a initial release for dnsd. 
contains the caching structures and a simple blacklist for the nameserver.
 2006-11-12 18:13:14 +00:00
nofreude d465ef05b7 added interface for dnsd 2006-11-12 18:00:10 +00:00
nofreude c2c01e9f4c Added functionality for dnsd: 
* some new auxiliary functions to deal with FQDNs.
 * better support for TXT- and HINFO-Ressource-Records.
 * extensions to the message parser like message-compression with
   mc-message->octets
 2006-11-12 17:48:36 +00:00
mainzelm 28cd440b4e Re-implement session timeouts using a hash table mapping session ids 
to timeouts and let the surveillance thread walk the table to find
outdated surflets. The previous implementation was nothing but bogus.
 2006-08-02 15:23:32 +00:00
mainzelm 8a2351a190 Fix handling of session timeouts by using the session-id as the only 
key.
 2006-08-01 15:19:19 +00:00
eknauel ef819fa581 Add structure `surflets/send-xml' which provides `send-xml/finish' and 
`send-xml/suspend'.  These functions produce XML output rather than
HTML.
 2006-07-10 12:02:39 +00:00
interp d0ffff7057 bindings.scm 2005-12-05 15:06:37 +00:00
sperber b9550cce3d Fix typo in FTP-RENAME. 2005-09-20 19:49:28 +00:00
interp 92c66ff35c Fix bug #805386: with-resolve-ip? -> with-resolve-ips? 2005-06-26 14:30:15 +00:00
sperber 7d6b83e370 Add record discloser for request objects. 2005-06-10 09:52:00 +00:00
sperber 64e2e8bc8a Add record disclosers. 2005-06-10 09:51:18 +00:00
sperber f3c436d746 Clarify optional attributes parameter to the various form element 
constructors.
 2005-06-10 09:26:57 +00:00
sperber 5b41e81721 Note name of URL structure. 2005-05-15 14:24:42 +00:00
sperber 57b04b0d36 Typo fix. 2005-05-15 14:21:40 +00:00
mainzelm 91da112ec1 Use Sunterlib's rt-modules implementation instead of our own. 2005-05-03 12:39:31 +00:00
vibr 6c80f06dd6 file handler-lib.scm was initially added on branch http-1-1. 2005-04-15 15:23:32 +00:00
sperber ae51c20165 Typo fix: "occured" -> "occurred" 2005-04-14 08:53:44 +00:00
eknauel 1ec6dc4f79 It's FTP-SET-TYPE! not SET-FTP-TYPE! 2004-12-21 08:46:05 +00:00
interp 78d29c9337 Fixed a bug in smtp-data, that did not handle multiline input-ports correctly. Reported by RichardAlan.5112949@bloglines.com. 2004-11-18 21:48:53 +00:00
mainzelm 8afd6710ef Fix email address 2004-10-26 08:30:42 +00:00
mainzelm a02a09ef92 Date 2004-10-26 07:52:10 +00:00
mainzelm 3d29fb1766 Bump version number to 2.1 2004-10-26 07:48:08 +00:00
interp 8959781279 Adapt to new server layout. File is only meant for developing. 2004-09-24 13:54:58 +00:00
interp 584c946850 remove debug output 2004-09-24 13:50:49 +00:00
interp 902a34ae01 really remove that POST-bindings-cache bug 2004-09-24 13:49:05 +00:00
interp 306d104c5b Fix broken startup procedure SERVER if called with no args. 2004-09-24 13:00:50 +00:00
interp f0ca612665 Remove bug that inhibited POST cache to shrink 2004-09-24 11:28:49 +00:00
interp d904121149 Fix typos and do some rephrasing. 2004-09-17 15:54:21 +00:00
mainzelm 58a540854f Update release date once more. 2004-08-09 08:58:50 +00:00
interp d0570a375e Fix typo. 2004-07-29 17:30:50 +00:00
interp 4a789540c9 Simplify. 2004-07-29 17:24:52 +00:00
interp 2f0b9d0b50 Add definition for syntax. 2004-07-29 17:23:17 +00:00
interp e319430837 Add other sections. Fix typo. 2004-07-29 17:22:29 +00:00
interp 46d17a3ee4 Export forgotten MAKE-TEXT in simple-surflet-api. 2004-07-29 17:15:46 +00:00
interp 0093759c8e The (complete?) SUrflet API documentation. 2004-07-29 16:21:14 +00:00
interp c1b264b9b1 Prepare for SUrflet API documentation. 2004-07-29 16:20:20 +00:00
interp bfb4068c9a Correct typo surlfets... -> surflets/input-fields. 2004-07-29 08:23:56 +00:00
interp 7cb5d680d4 Use sxml->low-level-sxml instead of pre-post-order in sxml->string to reduce connection points. 2004-07-28 20:59:55 +00:00
interp bc9e540be7 Remove wrong comment. 2004-07-28 20:20:50 +00:00
interp cb95474d95 Export RESET-SURFLET-CACHE! in surflet-handler/surflets. 2004-07-27 14:19:44 +00:00
interp fee49612ce Let surflets/my-sessions export SET-SESSION-LIFETIME! 2004-07-27 13:45:26 +00:00
interp 0783bdb4e2 fix small typo. 2004-07-26 20:24:05 +00:00
interp 584acf4441 Use send-html/finish instead of send-html for the single page. 2004-07-24 15:16:58 +00:00
interp 10ca480e4c Correct error message in make-http-response. 2004-07-21 20:38:00 +00:00
interp 6d6f34ae78 minor change: make clear Scheme value of not annotated checkbox depends on standard transformer. 2004-07-21 20:33:37 +00:00
interp 2268fe3231 Parameterize over error message in make-simple-default-setter 2004-07-21 20:31:30 +00:00
interp 15f07f8d4a Design change: transformer of non-multi input-fields get two 
arguments: the input-field *and* the binding value (not only the
binding value)

Rational: (a) transformers of non-multi input-fields can now access the
attribute field of the input-field record, (b) there is no real reason
why to treat multi and non-multi input-fields differently in respect
to their transformer arguments (keep design simple).

Updates of current surflets only necessary if they create their own
non-multi input-fields (with make-input-field).  Example surlfets
calculate.scm and calculate-cb.scm updated as well as standard HTML
input-fields provided by the SUrflets.
 2004-07-21 20:09:37 +00:00
interp 299a4ef815 add explaining comment 2004-07-21 19:07:50 +00:00
interp d62e069710 use (cdr head) instead of (cdar cache), it's clearer 2004-07-21 18:59:18 +00:00
interp 582e07bb18 remove forgotten debug output from previous commit 2004-07-21 18:56:56 +00:00
interp f23cd71100 use symbol to search in browser headers 2004-07-21 18:56:03 +00:00
interp 8b627decc5 Fix small typo. 2004-07-20 13:16:41 +00:00
mainzelm 84f5f3b625 Adjust year for Andreas 2004-07-20 07:51:33 +00:00
mainzelm d30807ed75 Update to 2004 and add Andreas 2004-06-21 12:35:03 +00:00
interp b264662160 Rewrite definition for proglist that irritate tex2page.sty 2004-06-05 13:57:51 +00:00
interp ebc119bb43 Remove superfluous float declaration that irritated tex2page. 2004-06-05 13:38:53 +00:00
eknauel f40d338fa2 + enforce coporate identity, it's SUnet not SUNet. 
+ fixed typos
 2004-06-02 14:26:03 +00:00
eknauel 46ae889df4 + added a "ssl with apache" section (draft) 2004-06-02 14:16:01 +00:00
mainzelm 7afbfadc42 Avoid DNS lookups 2004-05-29 15:23:32 +00:00
mainzelm 7e1b44518f Update date 2004-05-29 08:33:52 +00:00
mainzelm 88d28eec3f Reflect movement of sample httpd scripts 2004-05-29 08:33:24 +00:00
mainzelm b2e6d71264 Update installation and usage section 2004-05-29 08:28:35 +00:00
mainzelm 87c2ad3610 Fixed typo 2004-05-29 08:24:26 +00:00
63 changed files with 8696 additions and 667 deletions
Show Stats Expand all files Collapse all files

7
COPYING
View File

@ -1,7 +1,8 @@
Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
Copyright (c) 1996-2001 by Mike Sperber.
Copyright (c) 1999-2001 by Martin Gasbichler.
Copyright (c) 1998-2001 by Eric Marsden.
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

5
INSTALL
View File

@ -16,6 +16,11 @@ 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
============

1
Makefile
View File

@ -8,7 +8,6 @@ distdir = /tmp
DISTFILES = COPYING README RELEASE INSTALL pkg-def.scm \
scheme/packages.scm \
start-web-server start-extended-web-server start-surflet-server \
scheme/httpd/*.scm scheme/httpd/surflets/*.scm \
scheme/ftpd/*.scm scheme/lib/*.scm \
doc/pdf/sunet.pdf doc/html \

9
README
View File

@ -4,7 +4,7 @@ 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 und Unix.
Scsh's facilities for multi-threaded systems programming on Unix.
SUnet includes the following components:
@ -66,7 +66,8 @@ Installation
============
Starting with version 2.1 SUnet conforms to the packaging proposal for
scsh by Michel Schinz. Please see:
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/>
@ -106,7 +107,7 @@ Support
Please direct questions, comments, answers about SUnet to the regular
scsh mailing list at
scsh@zurich.ai.mit.edu
scsh-users@scsh.net
Relax, hack, and enjoy!
@ -114,4 +115,4 @@ Dr. S.
Dr. S.
Martin Gasbichler
Eric Marsden
Andreas Bernauer
Andreas Bernauer

32
doc/latex/decls.tex
View File

@ -222,6 +222,12 @@
{\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.
@ -285,21 +291,21 @@
\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}
%{\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{proglist}\begin{alltt}\small\normalem}
{\end{alltt}\end{proglist}}
{\ULforem\begin{alltt}\small\normalem}
{\end{alltt}}
\newenvironment{reflisting}[1]
{\ULforem\begin{proglist}[\refinlisting{#1}]\begin{alltt}\small\normalem}
{\end{alltt}\end{proglist}}
{\ULforem[\refinlisting{#1}]\begin{alltt}\small\normalem}
{\end{alltt}}
\newcommand{\contatlisting}[1]{%
{\normalfont\textit{$<$continued in listing~\ref{#1}\/$>$}}}
@ -310,14 +316,6 @@
\newcommand{\seelisting}[1]{%
{\normalfont{\textit{$<$see listing~\ref{#1}\/$>$}}}}
\newfloat{program}{t}{lop}
\floatname{program}{Programm}
\newenvironment{floatprog}[2]
{\begin{program}[ht] \caption{#1} \label{#2} \begin{alltt}}
{\end{alltt} \end{program}%
% Force output of even long floating figs
\afterpage{\clearpage}}
% 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}%

2
doc/latex/ftp.tex
View File

@ -23,7 +23,7 @@ code from the server, a catchable \ex{ftp-error} is raised.
\end{desc}
\dfn{ftp-type}{\synvar{name}}{ftp-type}{syntax}
\defunx{set-ftp-type!}{connection ftp-type}{undefined}
\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

60
doc/latex/httpd.tex
View File

@ -108,7 +108,7 @@ one. Here they are:
incoming to the Unix syslog facility. Defaults to \ex{\#t}.
\end{desc}
\defun{with-resolve-ip?}{resolve-ip? [options]}{options}
\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
@ -164,7 +164,7 @@ dissect requests are defined in the \texttt{httpd-requests} structure:
representing the version specified in the HTTP request.
\ex{Request-headers} returns an association lists of header field
names and their values, each represented by a list of strings, one
for each line. \ex{Request-socket} returns the the socket connected
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
@ -680,6 +680,62 @@ parse these strings.
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"

43
doc/latex/intro.tex
View File

@ -54,7 +54,7 @@ following components:
\end{itemize}
The server also ships with a sophisticated interface for writing
server-side Web applications called "SUrflets".
server-side Web applications called \textit{SUrflets}.
\item[The SUnet ftp server]
This is a complete anonymous ftp server in Scheme.
@ -82,21 +82,44 @@ following components:
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.4 or later of \urlhd{http://www.scsh.net/}{scsh}{scsh from
version 0.6.6 or later of \urlhd{http://www.scsh.net/}{scsh}{scsh from
\url{http://www.scsh.net/}}.
\section{How to use the packages}
\section{How to install SUnet}
Untar the SUnet distribution somewhere. Fire up scsh and load the
SUnet \texttt{packages.scm} file into the configuration package.
After that, all structures defined by SUnet are available:
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
Welcome to scsh 0.6.4 (...)
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.
> ,config ,load packages.scm
modules.scm
\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]

2
doc/latex/man.tex
View File

@ -51,7 +51,7 @@
\title{SUnet Reference Manual}
\subtitle{For SUnet release 2.1}
\author{Dr. S\raisebox{1ex}{2}, Martin Gasbichler, Eric Marsden, Andreas Bernauer}
\date{April 2004}
\date{October 2004}
\mainmatter
\maketitle

1679
doc/latex/surfletapi.tex Normal file
View File

File diff suppressed because it is too large Load Diff

289
doc/latex/surflethowto.tex
View File

@ -20,28 +20,31 @@
%%tableofcontents
%%sloppy
\section{Introduction}
\section{Howto}
\label{sec:surflethowto}
This howto gives a short introduction in how to write a \surflet. It
is concentrated on the practical side rather on describing the
\surflet API in detail to give you instant succes in running your own
surflets. The \surflet API will be described in the SUnet
documentation eventually.
surflets. See section \ref{sec:surflet-api} for the (technical) API
description.
\subsection{Introduction}
%\marginpar{\surflets are pieces of code for web site scripting.}
For those who don't know it already, \surflets are pieces of code that
can be executed interactively trough a website. There is a \surflet
handler who administrates their execution and suspension and as part
of the SUnet webserver. \surflets ease the implementation of web
applications in two ways, compared to other server-side scripting
tools like Java\texttrademark Servlets or Microsoft\textregistered
Active Server Pages or PHP:
can be executed interactively through a website. There is a \surflet
handler who administrates their execution and suspension. The
\surflet handler is part of the SUnet webserver. \surflets ease the
implementation of web applications in two ways, compared to other
server-side scripting tools like Java\texttrademark Servlets or
Microsoft\textregistered Active Server Pages or PHP:
\begin{enumerate}
\item \surflets have an automatic program flow control like any
other usual program, \ie the web designer doesn't have to care about
session management at all. The sequence of the web pages result from
their appearance in the program like the print statements in any other
usual program.
other usual program (but unlike usual web programs), \ie the web
designer doesn't have to care about session management at all. The
sequence of the web pages result from their appearance in the program
like the print statements in any other usual program.
\item \surflets come along with a library for robust user
interaction. \surflets represent interaction elements of the web page
@ -55,7 +58,7 @@ of the SUnet webserver and scsh. The environment variable
\typew{\$sunet} refers to the top level directory of your sunet
installation. On my system this is \name{/home/andreas/sw/sunet}.
\section{How to run the SUnet webserver that handles \surflets}
\subsection{How to run the SUnet webserver that handles \surflets}
The following sections will show pieces of \surflet code you might
want to try out. Therefore you need the SUnet webserver running with
@ -122,7 +125,7 @@ Going to run SUrflet server with:
htdocs-dir: /home/andreas/bin/lib/scsh/0.6/sunet-2.1/web-server/root/htdocs
surflet-dir: /home/andreas/bin/lib/scsh/0.6/sunet-2.1/web-server/root/surflets
images-dir: /home/andreas/bin/lib/scsh/0.6/sunet-2.1/web-server/root/img
port: 8008
port: 8080
log-file-name: /tmp/httpd.log
a maximum of 5 simultaneous requests, syslogging activated,
and home-dir-handler (public_html) activated.
@ -131,7 +134,7 @@ Going to run SUrflet server with:
\end{alltt}
This means the server is up and running. Try to connect to
\url{http://localhost:8008} with your browser and you will see the
\url{http://localhost:8080} with your browser and you will see the
welcome page of the SUnet server. There's a link to the
\surflets homepage. You can also already try out some of the
\surflets that come with the distribution.
@ -141,8 +144,8 @@ the first \surflet. This is because the server has to load the
\surflet libraries. The server handles further requests to \surflets
faster.
If the port the \surflet server tries to use is occupied use, you will
see an error message similar to this one:
If the port the \surflet server tries to use is occupied, you will see
an error message similar to this one:
\begin{alltt}
Error: 98
@ -150,7 +153,7 @@ Error: 98
#{Procedure 11701 (\%bind in scsh-level-0)}
4
2
(0 . 8008)
(0 . 8080)
\end{alltt}
In this case, pass another port number to the script, \eg 8000:
@ -160,12 +163,12 @@ The \typew{--help} option will show you more parameters that you can
adjust, but you won't need them for this howto.
\section{How to send web pages}
\subsection{How to send web pages}
This section will discuss some of the various ways in which you can
send a web page to a browser that contacted your \surflet.
\subsection{My first \surflet}
\subsubsection{My first \surflet}
\label{sec:first-surflet}
Traditionally, your first program in any programming language prints
@ -241,7 +244,7 @@ use to send web pages to the browser. The other two functions are
\name{send-html} and \name{send-html/suspend}.
\name{send-html/finish} -- as the name already suggests -- sends a
HTML page to the browser and finishes the \surflet. \name{send-html}
just sends the HTML page and does not return and
just sends the HTML page and does not return.
\name{send-html/suspend} sends the HTML page and suspends the
\surflet, \ie it waits until the user continues with the \surflet,
\eg by submitting a webform. We will discuss \name{send-html} and
@ -252,38 +255,35 @@ In a \surflet, HTML pages are represented as lists, or, to be more
precise, as SXML (S-expression based XML).\label{sec:SXML} The first
element of a SXML list is a symbol stating the HTML tag. The other
elements of a SXML list are the contents that are enclosed by this
HTML tag. The contents can be other SXML list, too. Here are some
HTML tag. The contents can be other SXML lists, too. Here are some
examples of SXML lists and how they translate to HTML:
\newcommand{\htmltag}[1]{$\mathtt{<}$#1$\mathtt{>}$}
\begin{tabbing}
HTML: \medskip\=\kill
SXML: \> \texttt{'(p "A paragraph.")} \\
HTML: \> \texttt{\htmltag{p}A paragraph.\htmltag{/p}}\\
%\newcommand{\htmltag}[1]{$\mathtt{<}$#1$\mathtt{>}$}
\begin{tabular}{ll}
SXML: & \verb|'(p "A paragraph.")}| \\
HTML: & \verb|<p>A paragraph.\htmltag{/p}}|\\
\\
SXML: \> \texttt{'(p "A paragraph." (br) "With break line.")} \\
HTML: \> \texttt{\htmltag{p}A paragraph.\htmltag{br}With break line.\htmltag{/p}}\\
SXML: & \verb|'(p "A paragraph." (br) "With break line.")}| \\
HTML: & \verb|<p>A paragraph.<br>With break line.</p>}|\\
\\
SXML: \> \texttt{'(p "Nested" (p "paragraphs"))}\\
HTML: \> \texttt{\htmltag{p}Nested\htmltag{p}paragraphs\htmltag{/p}\htmltag{/p}}\\
\end{tabbing}
SXML: & \verb|'(p "Nested" (p "paragraphs"))}|\\
HTML: & \verb|<p>Nested<p>paragraphs</p></p>}|\\
\end{tabular}
Attributes are stated by a special list whose first element is the
at-symbol. The attribute list must be the second element in the list:
\begin{tabbing}
HTML: \medskip\=\kill
SXML: \> \texttt{'(a (@ (href "attr.html")) "Attributed HTML tags.")} \\
HTML: \> \texttt{\htmltag{a href="attr.html"}Attributed HTML tags.\htmltag{/a}}\\
\begin{tabular}{ll}
SXML: & \verb|'(a (@ (href "attr.html")) "Attributed HTML tags.")|\\
HTML: & \verb|<a href="attr.html">Attributed HTML tags.</a>|\\
\\
SXML: \> \texttt{'(a (@ (href "attr2.html") (target "\_blank")) "2
attributes.")} \\
HTML: \> \texttt{\htmltag{a href="attr2.html" target="\_blank"}2
attributes.\htmltag{/a}}
\end{tabbing}
SXML: & \verb|'(a (@ (href "attr2.html") (target "\_blank")) "2
attributes.")}| \\
HTML: & \verb|<a href="attr2.html" target="\_blank">2 attributes.</a>}|
\end{tabular}
As you see from the \surflet example, \name{send-html/finish} expects
as an argument SXML. In the example, the SXML translates to the
SXML as an argument. In the example, the SXML translates to the
following HTML code:
\begin{alltt}
<html><body><h1>Hello, world!</h1>
@ -300,7 +300,7 @@ strings. Everything else like using valid HTML tags or valid
attributes is your responsibility.
\subsection{Dynamic content}
\subsubsection{Dynamic content}
Let's extend our first \surflet example by some dynamic content, \eg
by displaying the current time using scsh's \name{format-date}
@ -329,7 +329,7 @@ a regular quote (\typew{'}) as in the previous example.
Instead of passing a ``static'' list, \ie a list whose contents are
given before execution, this \surflet uses the quasiquote and unquote
feature of Scheme to create a ``dynamic'' list, \ie list whose
feature of Scheme to create a ``dynamic'' list, \ie a list whose
contents are given only during execution. A ``dynamic'' list is
introduced by a backquote (\typew{`}) and its dynamic contents are
noted by commata (\typew{,}). Thus, if the \surflet is executed while
@ -348,16 +348,16 @@ unquote feature. Of course, you can build your list in any way you
want; the quasiquote notation is just a convenient way to do it.
\subsection{Several web pages in a row}
\subsubsection{Several web pages in a row}
The previous example \surflets only showed one page and finished
afterwards. Here, we want to present to web pages in a row. We use
afterwards. Here, we want to present two web pages in a row. We use
the previously mentioned function \name{send-html/suspend}, which
suspends after it has send the page and continues when the user
suspends after it has sent the page and continues when the user
clicked for the next page. In contrast to \name{send-html/finish},
that expected SXML, \name{send-html/suspend} expects a function that
takes an argument and returns SXML. The parameter the function gets
(here: \name{k-url} is the URL that points to the next
(here: \name{k-url}) is the URL that points to the next
page:\footnote{In the API this URL is called the \emph{continuation
URL}.}
@ -381,7 +381,7 @@ This \surflet can be found in \name{howto/hello-twice.scm}. This
example first displays a web page with the message ``Hello, world!''
and a link to the next page labeled with ``Next page --$>$''. When the
user clicks on the provided link, \name{send-html/suspend} returns and
the the next statement after the call to \name{send-html/suspend} is
the next statement after the call to \name{send-html/suspend} is
executed. Here it is \name{send-html/finish} which shows a web page
with the message ``Hello, again!''.
@ -399,16 +399,16 @@ effects, \eg if you change a variable via \name{set!}. These
variables keep their modified values, allowing communication between
sessions of the same \surflet.\footnote{If you want to change a
variable via side effects but you don't want to interfere with other
session, you can use \name{set-session-data!} and
\name{get-session-data}. See the API documentation for further
information.}
sessions, you can use \name{set-session-data!} and
\name{get-session-data}. See the API documentation in section
\ref{sec:surflet-api} for further information.}
\subsection{Begin and end of sessions}
\subsubsection{Begin and end of sessions}
So far I don't have mentioned too much details about sessions. The
reason is, as mentioned before, that the \surflet handler takes of the
session automatically as described in the previous paragraph.
reason is, as mentioned before, that the \surflet handler takes care
of the session automatically as described in the previous paragraph.
%, \ie it starts the session automatically when an
%instance of your \surflet starts and takes care of the saving and
%restoring of all variable values during suspensions of your \surflet
@ -431,7 +431,7 @@ sending function is \name{send-html} which just sends a web page.
\name{send-html} does not return and does not touch the session of
your \surflet instance.
\subsection{Abbreviations in SXML}
\subsubsection{Abbreviations in SXML}
\label{sxml-abbrvs}
The example in subsection ``Several web pages in a row'' wrote down
@ -456,14 +456,14 @@ The last abbreviation, \name{surflet-form}, is discussed in the next
section.
\section{How to write web forms}
\subsection{How to write web forms}
The \surflets come along with a libary for easy user interaction. The
following subsections will show how to write web forms and how to get
the data the user has entered.
\subsection{Simple web forms}
\subsubsection{Simple web forms}
Let's write a \surflet that reads user input and prints it out on the
next page:
@ -509,8 +509,8 @@ objects. Thus, user interaction elements are first class values in
\surflet, unlike in many other web scripting languages, \eg Java
surflets, PHP or Microsoft Active Server Pages, \ie you have a
representation of a user interaction element in your program that you
can pass to functions, receive them as return values, etc. You'll see
soon the advantages of this approach.
can pass to functions, receive them as return values, etc. You'll
soon see the advantages of this approach.
\begin{alltt}
(req (send-html/suspend
@ -556,7 +556,7 @@ add the symbol \name{'POST} after the URL:
\end{alltt}
The web page \name{send-html/suspend} sends to the browser looks like
in figure [missing]
in figure [missing].
%\ref{fig:user1-1}.
After the user has entered his data into
the web form, \name{send-html/suspend} returns with the request object
@ -590,7 +590,7 @@ know what the user has entered into the \name{text-input-field}.
After we have extracted what the user has entered into the text field,
we can show the final page of our \surflet and echo her input.
The scheme for user interaction is thus about the following:
Thus, the scheme for user interaction is about the following:
\begin{itemize}
\item Create the user interaction elements, \name{input-field}s, you
@ -605,14 +605,14 @@ user data with \name{input-field-value}.
\end{itemize}
The complete list of functions that create \name{input-fields} can be
found in the API.
found in the API in section \ref{sec:surflet-api}.
\subsection{Return types other than strings}
\subsubsection{Return types other than strings}
\label{subsec:input-return}
As the user interaction elements are first class values in a \surflet,
they can return other types than strings. For example the \surflets
come with a number input field, \ie a input field that accepts only
come with a number input field, \ie an input field that accepts only
text that can be interpreted as a number. If the user enters
something that is not a number, \name{input-field-value} will return
\sharpf as the value of the number input field. If you'd rather want
@ -672,15 +672,15 @@ Let's go through the important part of this \surflet:
Here we define a select input field (a dropdown list). Instead of
only providing a list of values that shall show up in the dropdown
list and later examining which one was select and looking up the price
for the sweet, we bind the values in the list with the price while we
create the select input field. When the select input field is shown
in the browser, it will show the names of the sweets. When we lookup
the user's input, we will get the associated price for the sweet.
Again, this works not only with numbers, but with any arbitrary Scheme
value (\eg functions or records).
list and later examining which one was selected and looking up the
price for the sweet, we bind the values in the list with the price
while we create the select input field. When the select input field
is shown in the browser, it will show the names of the sweets. When
we lookup the user's input, we will get the associated price for the
sweet. Again, this works not only with numbers, but with any
arbitrary Scheme value (\eg functions or records).
\subsection{Sending error messages}
\subsubsection{Sending error messages}
If a user tries to forge a \surflet-URL (\eg by extracting the
continuation URL from the HTML source and editing it), your \surflet
@ -688,7 +688,7 @@ has to deal with unexpected values. Usually, a forged \surflet-URL
will result in an error that is raised in one of the \surflet library
functions. If you don't catch this error, the \surflet handler will
catch it for you, send an error message to the user
\emph{and terminating the current session} as your \surflet obviously
\emph{and terminate the current session} as your \surflet obviously
encountered an unexpected error and might be in an invalid state. If
you don't want this behavior, you can catch this error (like any other
error that is raised by \scsh) and send your own error message with
@ -700,8 +700,8 @@ previous subsection (modifications emphasized):
\begin{listing}
(define-structure surflet surflet-interface
(open surflets
\codemph{ handle-fatal-error
surflets/error}
\codemph{ handle-fatal-error}
\codemph{ surflets/error}
scheme-with-scsh)
(begin
(define (main req)
@ -722,14 +722,14 @@ previous subsection (modifications emphasized):
,select-input-field)
,(make-submit-button)))))))
(bindings (get-bindings req))
\codemph{ (cost (with-fatal-error-handler
(lambda (condition decline)
(send-error (status-code bad-request)
req
"No such option or internal
error. Please try again."))
(raw-input-field-value select-input-field
bindings))))}
\codemph{ (cost (with-fatal-error-handler }
\codemph{ (lambda (condition decline) }
\codemph{ (send-error (status-code bad-request)}
\codemph{ req }
\codemph{ "No such option or internal }
\codemph{ error. Please try again."))}
\codemph{ (raw-input-field-value select-input-field }
\codemph{ bindings)))) }
(send-html/finish
`(html (head (title "Receipt"))
(body
@ -753,7 +753,7 @@ Let's examine the important part of this example:
As mentioned in \ref{subsec:input-return}, this \surflet uses
\name{raw-input-field-value} instead of \name{input-field-value}
because the former raises an error while the latter returns \sharpf in
because the former raises an error while the latter returns \sharpf\ in
case of an error.
If a user forges a continuation URL, \name{raw-input-field-value}
@ -765,7 +765,7 @@ by the error handler which was installed by
argument is the status code of the error message. See the
documentation of the \sunet webserver for different status codes. The
second argument is the request which was processed while the error
occured. The last argument is a free message text to explain the
occured. The last argument is a free text message to explain the
cause of the error to the user.
While in the original \surflet the user will still see the resulting
@ -783,17 +783,18 @@ does not appear in the data the browser sends to the server. Thus,
raise an error which is not a ``real'' error as you migh expect it.
\subsection{Your own input fields}
\subsubsection{Your own input fields}
The \surflet library contains constructors for all input fields that
are described in the HTML~2.0 standard. See the \surflet API for a
complete list. The \surflet library also allows you to create your
own input fields, \eg an input field that only accepts valid dates as
its input. This subsection gives you a short overview how to do
this. You will find the details in the \surflet API.
are described in the HTML~2.0 standard. See the \surflet API in
section \ref{sec:surflet-api} for a complete list. The \surflet
library also allows you to create your own input fields, \eg an input
field that only accepts valid dates as its input. This subsection
gives you a short overview how to do this. You will find the details
in the \surflet API.
Let's have a look at an \surflet that uses its own input field. The
``input field'', called nibble input field, consists of eight check
``input field'', called nibble input field, consists of four check
boxes which represent bits of a nibble (half a byte). The value of
the input field is the number that the check boxes represent. \Eg, if
the user checks the last two checkboxes, the value of the nibble input
@ -914,7 +915,7 @@ associated to its name.
The transformer function of our nibble input field goes over each
check box, looks it up in the bindings and adds its value to a sum, if
\name{input-field-value} can find it. If it can't find it, a zero is
\name{input-field-value} can find it. If it can't find it, zero is
added instead. The value of our nibble input field is the resulting
sum.
@ -923,7 +924,7 @@ again. We create, use and evaluate the nibble input field as we do
with every other input field.
\section{Program flow control}
\subsection{Program flow control}
With the techniques shown so far it is rather difficult to create a
web page that has several different successor webpages rather than
@ -934,7 +935,7 @@ the mark after \name{send-html/suspend} has returned. The other
method is to bind a callback function to each link that is called when
the user selects the link. This section shows both methods.
\subsection{Dispatching to more than one successor web page}
\subsubsection{Dispatching to more than one successor web page}
The basic idea of dispatching is to add a mark to a link and evaluate
it after the user has clicked on a link and \name{send-html/suspend}
@ -1021,8 +1022,8 @@ link the user has clicked by using \name{case-returned-via}.
\name{case-returned-via} works similar to the regular \name{case} of
Scheme. It evaluates the body of the form whose initial list contains
the address that the user used to leave the website. \Eg, if the user
has selected ``German'' as her preferred language and thus clicked on
the link we have named \name{german} in our \surflet,
has selected ``German'' as her preferred language and clicked on the
link we have named \name{german} in our \surflet,
\name{case-returned-via} will evaluate its second form and the
\surflet will display the greeting in German.
@ -1037,7 +1038,7 @@ shortly. Of course, it is your choice if you want to use
\name{case-returned-via} or explicitly \name{returned-via}.
\subsection{Annotated dispatching}
\subsubsection{Annotated dispatching}
The approach shown in the previous subsection has one major drawback:
the meaning of an address becomes clear only when you look at the
@ -1063,11 +1064,11 @@ We modify the previous code example slightly to this \surflet
(body
(h2 "Select your language:")
(ul
(li (url ,\codemph{(language k-url
"Hello, how are you?")}
(li (url ,\codemph{(language k-url }
\codemph{ "Hello, how are you?")}
"English")
(li (url ,\codemph{(language k-url
"Hallo, wie geht es Ihnen?")}
(li (url ,\codemph{(language k-url }
\codemph{ "Hallo, wie geht es Ihnen?")}
"Deutsch")))))))))
(bindings (get-bindings req)))
(case-returned-via bindings
@ -1127,14 +1128,14 @@ via which the user has left the web page. \name{returned-via} returns
created with this address (which is not really possible in this
example).
\subsection{Callbacks}
\subsubsection{Callbacks}
The other method to lead to different successor web pages is using
callbacks. A callback is a function that is called if the user leaves
the web page via an associated link. This is different from the
dispatch method where \name{send-html/suspend} returns. You can
create a web page that only uses callbacks to lead to successor web
page and thus you don't have to use \name{send-html/suspend}.
pages and you don't have to use \name{send-html/suspend}.
Instead, you can use \name{send-html}.
Although it is possible to use several different callbacks in a single
@ -1182,7 +1183,8 @@ callbacked function must accept the request from the browser as the
first argument. Furthermore, you don't have to use
\name{send-html/suspend}, if a user can only leave your web page via
callbacks. However, it can be sensible to combine the dispatch and
the callback method, so you have to use \name{send-html/suspend}.
the callback method, in which case you have to use
\name{send-html/suspend}.
Note that is nonsensical to create a callback on top level, \ie the
call to \name{make-annotated-callback} must occur every time
@ -1203,7 +1205,7 @@ you can instruct the callback to call different functions like this:
\begin{alltt}
(callback function1 arg1 arg2)
\dots
\dots \\
(callback function2 arg3 arg4 arg5)
\end{alltt}
@ -1212,19 +1214,19 @@ calling a function with several arguments and of different amount each
time is also possible if you only use a single function for the
callback.
\section{Data management}
\subsection{Data management}
When you write web programs, there are usually two kinds of data that
you use: data that is local to each instance of a \surflet, \eg the
users login, and data that is global to each instance of a \surflet,
user's login, and data that is global to each instance of a \surflet,
\eg a port to a logfile. Changes to local data is only visible to
each instance of a \surflet, while changes to global data is visible
to every instance of a \surflet.
each session of a \surflet, while changes to global data is visible
to every session of a \surflet.
The \surflet library does not really distinguish between these two
types of data, but provides ways to realize both of them in a
convenient way that is not (really) different from the way you handle
this data types in a regular Scheme program.
these data types in a regular Scheme program.
If a data item is globally used in your \surflet, define it global
(on top level) and change its values with \name{set!}. If a data
@ -1238,7 +1240,7 @@ is that the \surflets are implemented with continuations.
Continuations cannot reflect changes that are done via \name{set!} (or
side effects in general) and thus such changes are globally visible.
On the other hand continuations represent states of a program and a
reified continuations reifies also the values of all (local) data.
reified continuations reifies also the values of all data.
But what to do if you happen to want to change your \emph{local}
data's value with \name{set!}? The \surflet library provides a place
@ -1341,13 +1343,13 @@ endless states of the \surflet.
\name{cancel} shows the final page with the amount of clicks
performed.
\section{My own SXML}
\subsection{My own SXML}
Section \ref{sec:SXML} introduced SXML, the way how \surflets
represent HTML. This section will show you, how you can create your
own rules to translate from SXML to HTML.
\subsection{Terms and theoretical background}
\subsubsection{Terms and theoretical background}
This subsection will introduce the main concepts of the translation
process and some necessary terms we will use in the following.
@ -1355,53 +1357,48 @@ process and some necessary terms we will use in the following.
The translation process from SXML to HTML takes two steps. In the
first step, SXML is translated to an intermediate form. This is done
by the \textit{translator}. In the second step, the intermediate form
is translated into an HTML string. This is done by the
is printed into an HTML string. This is done by the
\textit{printer}. The intermediate form looks very much like SXML,
but contains only atoms or, recursively, list of \textit{atoms}.
but contains only \textit{atoms} or, recursively, list of atoms.
Atoms are numbers, characters, strings, \sharpf, and the empty list.
We call the intermediate form an \textit{atom tree} and the list from
which we've started an \textit{SXML tree}.
The basic unit in the translation process is a \textit{conversion
rule}. A conversion rule consists of a trigger and a conversion
function. The translator calls the conversion function when it sees
the trigger at the beginning of a list in the SXML tree, \ie at a
node. It calls the conversion function with the all list elements as
function. As its first element, the trigger identifies the list for
which the translator shall call the conversion function. The
translator calls the conversion function with all list elements as
parameters and replaces the whole list by the result of the conversion
function. The result of the conversion function is supposed to be an
atom tree.
The translator gets the SXML tree and a list of conversion rules as
The translator takes the SXML tree and a list of conversion rules as
arguments. It then traverses the SXML tree depth first and calls the
conversion functions according to the triggers it encounters,
replacing the nodes in the SXML tree with the result of the conversion
functions it called for each node. The result of this translation
step will be an atom tree, which the printer will print to a port.
replacing the nodes in the SXML tree with the return values of each
conversion function called. The result of this translation step will
be an atom tree, which the printer will print into a string or port.
There are exceptions to this basic rules. First, the translator might
not traverse the whole SXML tree. If the translator traverses the
whole tree, every argument to a conversion function is first
translated before it is passed to the conversion function. This is
the regular case and we say the conversion function gets its arguments
\textit{preprocessed}. However, the conversion rule can instruct the
translator not to preprocess the conversion function's arguments and
pass the arguments as they are in the SXML tree, \ie
\textit{unprocessed}. In that case, the translator will stop
traversing the SXML tree at that node and replacing the whole node by
the result of the conversion function called for this node.
The translator calls the conversion function in two different modes,
depending on the conversion rule. The regular mode is the
\textit{preprocess} mode: the translator translates every argument of
the conversion function before calling it. The other mode is the
\textit{unprocessed} mode: the translator calls the conversion
function directly without preprocessing the arguments. This is, the
translator stops traversing the SXML tree at nodes that trigger a
conversion rule in unprocessed mode.
Second, there are two default triggers which you can't use in your
translation rules: \typew{*default*} and \typew{*text*}. The
conversion rule that uses \typew{*default*} as its trigger is the
default conversion rule which the translator uses if no other
conversion rule triggers for a node in the SXML tree. The conversion
rule that uses \typew{*text*} as its trigger is the text conversion
rule and triggers, if the node in the SXML tree is a string. In the
standard conversion rule set the text conversion rule performs HTML
escaping, \eg for the ampersand (\&).
There are two default triggers which you can't use in your translation
rules: \typew{*default*} and \typew{*text*}. \typew{*default*} as the
trigger marks the default conversion rule which the translator uses if
no other conversion rule triggers. \typew{*text*} marks the text
conversion rule and triggers, if the node in the SXML tree is a
string. In the standard conversion rule set the text conversion rule
performs HTML escaping, \eg for the ampersand (\&).
\section{Outlook}
\subsubsection{Outlook}
More to come soon about \surflets consisting of different parts and
individual SXML.

9
doc/latex/surflets.tex
View File

@ -3,9 +3,12 @@
\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 lot of example
files in \typew{httpd/surflet/webserver/root/surflets} from which you
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}

6
doc/latex/url.tex
View File

@ -1,7 +1,7 @@
\chapter{Parsing and Processing URLs}\label{cha:url}
%
This modules contains procedures to parse and unparse URLs. Until
now, only the parsing of HTTP URLs is implemented.
The \ex{url} structure contains procedures to parse and unparse URLs.
Until now, only the parsing of HTTP URLs is implemented.
\section{Server Records}
@ -61,7 +61,7 @@ For details about escaping and unescaping see Chapter~\ref{cha:uri}.
\defunx{http-url-server}{http-url}{server}
\defunx{http-url-path}{http-url}{list}
\defunx{http-url-search}{http-url}{string-or-\sharpf}
\defunx{http-url-frag-ment-identifier}{http-url}{string-or-\sharpf}
\defunx{http-url-fragment-identifier}{http-url}{string-or-\sharpf}
%
\begin{desc}
\ex{Make-http-url} creates a new \ex{httpd-url} record.

82
scheme/dnsd/README Normal file
View File

@ -0,0 +1,82 @@
***********************
*** 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.

170
scheme/dnsd/cache.scm Normal file
View File

@ -0,0 +1,170 @@
; ----------------------------
; --- 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)))))

674
scheme/dnsd/database.scm Normal file
View File

@ -0,0 +1,674 @@
;; ---------------------
;; --- 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*))))

134
scheme/dnsd/db-options.scm Normal file
View File

@ -0,0 +1,134 @@
;; ------------------------
;; --- 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."))))

836
scheme/dnsd/dnsd.scm Normal file
View File

@ -0,0 +1,836 @@
; ------------------
; --- 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)))))))

103
scheme/dnsd/etc/dnsd-options.scm Normal file
View File

@ -0,0 +1,103 @@
;; 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)

3
scheme/dnsd/etc/dnsd-post.scm Normal file
View File

@ -0,0 +1,3 @@
(lambda (msg socket-addr dnsd-options)
(display "Postprocessing works.")
(values msg dnsd-options))

3
scheme/dnsd/etc/dnsd-pre.scm Normal file
View File

@ -0,0 +1,3 @@
(lambda (msg socket-addr dnsd-options)
(display "Preprocessing works.")
(values msg dnsd-options))

80
scheme/dnsd/etc/dnsd-zones.scm Normal file
View File

@ -0,0 +1,80 @@
;; 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:
()

30
scheme/dnsd/etc/zone-example-rfc Normal file
View File

@ -0,0 +1,30 @@
$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

19
scheme/dnsd/etc/zone-example-scheme Normal file
View File

@ -0,0 +1,19 @@
; 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")))

34
scheme/dnsd/logging.scm Normal file
View File

@ -0,0 +1,34 @@
; ------------------------
; --- 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)))

369
scheme/dnsd/masterfile-parser.scm Normal file
View File

@ -0,0 +1,369 @@
; -------------------------
; --- 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)))

41
scheme/dnsd/masterfile.l Normal file
View File

@ -0,0 +1,41 @@
; --------------------
; --- 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))

1286
scheme/dnsd/masterfile.l.scm Normal file
View File

File diff suppressed because it is too large Load Diff

214
scheme/dnsd/options.scm Normal file
View File

@ -0,0 +1,214 @@
; ---------------------
; --- 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.")))

753
scheme/dnsd/resolver.scm Normal file
View File

@ -0,0 +1,753 @@
; ----------------
; --- 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))))

177
scheme/dnsd/rr-def.scm Normal file
View File

@ -0,0 +1,177 @@
; ----------------------------------
; --- 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))))

105
scheme/dnsd/rw-locks.scm Normal file
View File

@ -0,0 +1,105 @@
; -----------------------
; --- 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))

83
scheme/dnsd/semaphores.scm Normal file
View File

@ -0,0 +1,83 @@
; ----------------------
; --- 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.")))

364
scheme/dnsd/slist.scm Normal file
View File

@ -0,0 +1,364 @@
; -----------------------
; --- 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)))))

3
scheme/ftpd/ftpd.scm
View File

@ -346,7 +346,6 @@
protocol-family/internet
(lambda (socket address)
(let ((remote-address (socket-address->string address)))
(set-ftp-socket-options! socket)
(fork-thread
(lambda ()
(handle-connection-encapsulated ftpd-options
@ -375,6 +374,8 @@
(log (syslog-level debug) "socket: ~S" socket-string)
(set-ftp-socket-options! socket)
(dynamic-wind
(lambda () 'fick-dich-ins-knie)
(lambda ()

2
scheme/httpd/core.scm
View File

@ -164,7 +164,7 @@
(values #f
(apply make-error-response (status-code internal-error)
#f ; don't know
"Internal error occured while processing request"
"Internal error occurred while processing request"
c)))
(else
(decline))))

4
scheme/httpd/logging.scm
View File

@ -154,7 +154,7 @@
(with-errno-handler*
(lambda (errno packet)
(http-syslog (syslog-level warning)
"[httpd] Warning: An error occured while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
"[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))
@ -187,7 +187,7 @@
(or (with-fatal-error-handler*
(lambda (condition decline)
(http-syslog (syslog-level debug)
"An error occured while resolving IP ~A: ~A"
"An error occurred while resolving IP ~A: ~A"
remote-ip condition)
remote-ip)
(lambda ()

4
scheme/httpd/response.scm
View File

@ -233,7 +233,7 @@
misconfiguration and was unable to complete your request.
<P>
Please inform the server administrator, ~A, of the circumstances leading to
the error, and time it occured.~%"
the error, and time it occurred.~%"
(or (httpd-options-server-admin options)
"[no mail address available]"))
(send-message port)
@ -255,7 +255,7 @@ the requested method (~A).~%"
'()
(lambda (port options)
(generic-title port)
(format port "An error occured while waiting for the
(format port "An error occurred while waiting for the
response of a gateway.~%")
(send-message port)
(close-html port)))))))

37
scheme/httpd/surflets/bindings.scm
View File

@ -10,7 +10,7 @@
(define (get-bindings surflet-request)
(let ((request-method (surflet-request-method surflet-request))
(content-type (assoc "content-type"
(content-type (assoc 'content-type
(surflet-request-headers surflet-request))))
;; Check if we the content-type is the one we support. If there's
@ -54,23 +54,30 @@
(define (cached-bindings surflet-request)
(obtain-lock *cache-lock*)
(let ((result
(let loop ((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)
(cdar cache) ; request is cached
(loop (cdr cache))) ; request isn't cached
(begin
;; request object is gone ==> remove it from list
(set! cache (cdr cache))
(loop cache))))))))
(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) =>

3
scheme/httpd/surflets/input-fields.scm
View File

@ -124,7 +124,8 @@
((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) (cdr binding))))
((real-input-field-transformer real-input-field)
input-field (cdr binding))))
(else
(error "no such input-field" input-field bindings)))))

41
scheme/httpd/surflets/load-surflet-server.scm
View File

@ -1,35 +1,16 @@
; reads package description in the right order
; in the end, the server can be started via (server)
;;; 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/
(batch 'on)
(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*)
"/scheme/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*)
"/scheme/httpd/surflets/packages.scm"))))
(define *SURFLET-SERVER*
(in 'scsh `(run (string-append
(or (getenv "SUNETHOME")
,*ASSUMED-SUNET-HOME*)
"/start-surflet-server"))))
(config `(load ,*SUNET-PACKAGE*))
(config `(load ,*SSAX-PACKAGE*))
(config `(load ,*SURFLET-PACKAGE*))
(config `(load ,*SURFLET-SERVER*))
(config `(load "../../packages.scm"))
(config `(load "packages.scm"))
(config `(load "../../../web-server/start-surflet-server"))
(user)
(open 'surflet-server)
(batch 'off)

89
scheme/httpd/surflets/packages.scm
View File

@ -122,6 +122,7 @@
session-alive?
session-surflet-name
session-session-id
set-session-lifetime!
options-surflet-path
options-session-lifetime
options-cache-surflets?
@ -147,7 +148,8 @@
(define-interface surflet-handler/surflets-interface
(export get-loaded-surflets
unload-surflet))
unload-surflet
reset-surflet-cache!))
(define-interface surflet-handler/options-interface
(export make-surflet-options
@ -191,6 +193,7 @@
form-query
inform
final-page
make-text
make-password
make-number
make-boolean
@ -252,25 +255,6 @@
thread-safe-counter-next!
thread-safe-counter?))
;; These two are from 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))
(define-interface rt-modules-interface
(export interface-value-names
reify-structure
load-config-file
rt-structure-binding
load-structure))
(define-interface with-locks-interface
(export with-lock*
(with-lock :syntax)))
@ -399,7 +383,9 @@
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
@ -437,7 +423,7 @@
let-opt ;:OPTIONAL
locks ;MAKE-LOCK et al.
profiling ;PROFILE-SPACE
rt-module-language ;get structures dynamically
rt-modules ;get structures dynamically
scheme-with-scsh ;regexp et al.
search-trees
shift-reset ;SHIFT and RESET
@ -467,6 +453,14 @@
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
@ -571,7 +565,7 @@
)
(files input-fields))
(define-structure surlfets/input-fields surflets/my-input-fields)
(define-structure surflets/input-fields surflets/my-input-fields)
(define-structure surflets/surflet-input-fields
surflets/surflet-input-fields-interface
@ -675,53 +669,6 @@
surflets/surflet-sxml)
(files send-html))
;; These two are from Martin Gasbichler:
(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))
(define-structure with-locks with-locks-interface
(open scheme
locks)
@ -729,5 +676,5 @@
;;; EOF
;;; Local Variables:
;;; buffer-tag-table: "../../TAGS"
;;; buffer-tag-table: "../../../TAGS"
;;; End::

58
scheme/httpd/surflets/rt-module.scm
View File

@ -1,58 +0,0 @@
;; 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)))

60
scheme/httpd/surflets/send-xml.scm Normal file
View File

@ -0,0 +1,60 @@
(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))))

50
scheme/httpd/surflets/surflet-handler.scm
View File

@ -93,7 +93,7 @@
(delete-session! session-id)
(bad-surflet-error-response s-req path-string condition))
(let ((surflet (get-surflet-rt-structure path-string surflet-path)))
(timeout-queue-register-session! session-id (+ (time) lifetime))
(register-session-timeout! session-id (+ (time) lifetime))
(reset
(with-fatal-error-handler
@ -117,34 +117,32 @@
;;; SESSION-SURVEILLANCE
(define *timeout-queue*)
(define *session-timeouts*)
(define (timeout-queue-register-session! session-id timeout)
(search-tree-set! *timeout-queue* (cons session-id timeout) 'ignore))
(define (register-session-timeout! session-id timeout)
(table-set! *session-timeouts* session-id timeout))
(define (timeout-queue-remove-session! session-id)
(search-tree-set! *timeout-queue* (cons session-id 0) #f))
(define (timeout-queue-adjust-session-timeout! session-id new-timeout)
(search-tree-set! *timeout-queue* (cons session-id new-timeout) 'ignore))
(define (remove-session-timeout! session-id)
(table-set! *session-timeouts* session-id #f))
(define (adjust-session-timeout! session-id new-timeout)
(table-set! *session-timeouts* session-id new-timeout))
(define (surveillance-thread)
(set! *timeout-queue* (make-search-tree (lambda (p q) (eq? (car p) (car q)))
(lambda (p q)
(< (cdr p) (cdr q)))))
(set! *session-timeouts* (make-integer-table))
(let lp ()
(with-lock *session-table-lock*
(let ((now (time)))
(let lp2 ()
(receive (session-id.time ignore) (search-tree-min *timeout-queue*)
(if session-id.time
(if (<= (cdr session-id.time) now)
(let ((session-id (car session-id.time)))
(table-set! *session-table* session-id #f)
(pop-search-tree-min! *timeout-queue*)
(lp2))))))))
(sleep 1000)
(let ((now (time))
(dead-sessions '()))
(table-walk (lambda (session-id timeout)
(if (<= timeout now)
(set! dead-sessions (cons session-id dead-sessions))))
*session-timeouts*)
(for-each (lambda (session-id)
(remove-session-timeout! session-id)
(table-set! *session-table* session-id #f))
dead-sessions)))
(sleep 10000)
(lp)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -266,7 +264,7 @@
(display "Error in SUrflet output: no valid data.\n" out))
))))
(make-error-response (status-code internal-error) #f
"The SUrflet returned an invalid response object (no surflet-response)."))))
"The SUrflet returned an invalid response object (wrong data type in surflet-response)."))))
((and (response? response) ;; RESPONSE? refers to a HTTP-RESPONSE.
(redirect-body? (response-body response)))
response)
@ -302,7 +300,7 @@
(let ((session (table-ref *session-table* session-id)))
(if session
(begin
(timeout-queue-remove-session! session-id)
(remove-session-timeout! session-id)
(table-set! *session-table* session-id #f))
;; else: somebody was faster than we
))))
@ -320,7 +318,7 @@
(with-lock *session-table-lock*
(let ((session (table-ref *session-table* session-id)))
(if session
(timeout-queue-adjust-session-timeout!
(adjust-session-timeout!
session-id
(+ (time) time-to-live))
(error "There is no session with this ID" session-id)))))
@ -360,7 +358,7 @@
;; notify session killing
(table-walk
(lambda (session-id session)
(timeout-queue-remove-session! session-id))
(remove-session-timeout! session-id))
*session-table*)
(set! *session-table* (make-integer-table)))))

33
scheme/httpd/surflets/surflet-input-fields.scm
View File

@ -39,13 +39,13 @@
,(field-attributes-default attributes)
,(field-attributes-others attributes))))))
(define (make-simple-default-setter default-pred?)
(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 "Default value must be a number or a string or a symbol."
(error (format #f "Default value must be ~a." error-msg-types)
value))
(touch-input-field! input-field)))
@ -54,12 +54,14 @@
(define simple-default? string-or-symbol?)
(define set-simple-field-default!
(make-simple-default-setter simple-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? identity))
(simple-field-maker "text" "text" simple-default? second-arg))
(define set-text-field-value! set-simple-field-default!)
;;;;;;;;;;;;;;;;;;;;;;
@ -67,14 +69,15 @@
(define (number-field-default? value)
(or (number? value)
(simple-default? value)))
(define (number-field-transformer string)
(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?))
(make-simple-default-setter number-field-default?
"a number a string or a symbol"))
;;;;;;;;;;;;;;;;;;;;;;
;;; hidden input-field
@ -82,14 +85,14 @@
;; as it is hidden.
(define make-hidden-field
(simple-field-maker "hidden" "hidden"
simple-default? identity))
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? identity))
simple-default? second-arg))
(define set-password-field-value! set-simple-field-default!)
;;; That's it for simple input fields.
@ -110,7 +113,7 @@
,@(sxml-attribute-attributes attributes))))
(make-input-field
name "textarea"
identity
second-arg
(make-field-attributes (and default-text)
all-attributes)
make-textarea-html-tree))))
@ -282,7 +285,7 @@
;; internal
(define (make-single-select name select-options attributes)
(make-input-field name "select"
(lambda (tag)
(lambda (input-field tag)
(cond ((find-select-option-value tag select-options)
=> identity)
(else (error "no such option." tag))))
@ -330,7 +333,7 @@
((checked? #f boolean?)
(attributes '() sxml-attribute?))
(make-input-field name "radio"
identity
second-arg
(make-field-attributes
(and checked? '(checked))
`((value ,value-string)
@ -367,7 +370,7 @@
(define (make-radio-transformer value-table)
(lambda (tag)
(lambda (input-field tag)
(cond
((string->number tag) =>
(lambda (number)
@ -398,7 +401,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;
;;; checkbox input-field
(define (make-checkbox . maybe-further-attributes)
(really-make-checkbox #t
(really-make-checkbox 'defined-in-checkbox-transformer
checkbox-transformer
maybe-further-attributes))
@ -420,7 +423,7 @@
checkbox-html-tree-maker))))
(define (make-checkbox-transformer value)
(lambda (tag)
(lambda (input-field tag)
(if (string=? tag "on")
value
#f)))
@ -443,7 +446,7 @@
;; button input-fields
(define (make-button type name button-caption attributes)
(make-input-field name type
identity
second-arg
(make-field-attributes
(and button-caption `(value ,button-caption))
(sxml-attribute-attributes attributes))

5
scheme/httpd/surflets/surflet-request.scm
View File

@ -7,6 +7,11 @@
(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))))

1
scheme/httpd/surflets/surflet-sxml.scm
View File

@ -53,6 +53,7 @@
`(form (@ ((method ,real-method)
(action ,k-url)
,@(if attributes (cdr attributes) '())))
;; cdr == sxml-attribute-attributes
,@elems))))
(define input-field-rule

6
scheme/httpd/surflets/sxml.scm
View File

@ -2,10 +2,6 @@
;;; adapted from Oleg's SXML-tree-trans.scm SRV:send-reply
;;; extended by port argument
;;; #t: current-output-port
;;; #f: string
;;; port: port
;;; else: error
;; Displays low-level-sxml on the port. Low-level-sxml contains only
;; strings, characters and thunks. '() and #f are ignored.
(define (display-low-level-sxml fragments port)
@ -31,7 +27,7 @@
(call-with-string-output-port
(lambda (port)
(display-low-level-sxml
(pre-post-order sxml-tree rules)
(sxml->low-level-sxml sxml-tree rules)
port))))
(define (sxml->string/internal sxml-tree rules)

805
scheme/lib/dns.scm
View File

File diff suppressed because it is too large Load Diff

2
scheme/lib/ftp.scm
View File

@ -138,7 +138,7 @@
(values)))
(define (ftp-rename connection oldname newname)
(ftp-send-command connection (build-command "RNFR " oldname)
(ftp-send-command connection (build-command "RNFR" oldname)
(code-with-prefix "35"))
(ftp-send-command connection (build-command "RNTO" newname)
(code-with-prefix "25"))

2
scheme/lib/smtp.scm
View File

@ -188,7 +188,7 @@
(if (not (eof-object? stuff))
(begin
(write-data-line stuff p)
(newline))))))
(lp))))))
(else (error "Message must be string or input-port.")))

10
scheme/lib/url.scm
View File

@ -39,6 +39,11 @@
(host server-host)
(port server-port))
(define-record-discloser :server
(lambda (s)
(list 'server
(server->string s))))
;;; Parse a URI path (a list representing a path, not a string!) into
;;; a server record. Default values are taken from the server
;;; record DEFAULT except for the host. Returns a server record if
@ -115,6 +120,11 @@
(search http-url-search)
(fragment-identifier http-url-fragment-identifier))
(define-record-discloser :http-url
(lambda (url)
(list 'http-url
(http-url->string url))))
;;; The URI parser (parse-uri in uri.scm) maps a string to four parts:
;;; <scheme> : <path> ? <search> # <frag-id> <scheme>, <search>, and
;;; <frag-id> are strings; <path> is a non-empty string list -- the

399
scheme/packages.scm
View File

@ -7,6 +7,7 @@
;;; Copyright (c) 1996-2002 by Mike Sperber.
;;; Copyright (c) 2000-2002 by Martin Gasbichler.
;;; Copyright (c) 1998-2001 by Eric Marsden.
;;; Copyright (c) 2005-2006 by Norbert Freudemann.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
@ -147,7 +148,7 @@
dns-inverse-lookup ; obsolete, use dns-lookup-ip
dns-lookup-ip ; simple lookup function
dns-lookup-nameserver ; simple lookup function
dns-lookup-mail-exchanger ; simple lookpu function
dns-lookup-mail-exchanger ; simple lookup function
pretty-print-dns-message ; prints a human readable dns-msg
force-ip ; reruns a lookup until a ip is resolved
force-ip-list ; reruns a lookup until a list of ips is resolved
@ -160,7 +161,25 @@
host-fqdn
system-fqdn
dns-get-information
address32? ; for dnsd.scm
octet-pair->number ; -"-
number->octet-pair ; -"-
parse ; -"- produces a message-record-type
mc-message->octets ; -"- produces a byte-encoded (compressed) message
make-fqdn-name ; -"- maybe adds an ending dot to a string
fqdn? ; -"- checks for fully quallified domain names
cut-name ; -"- domain name split tool
dn-split? ; -"- domain name split tool
dns-server-error? ; -"- error condition predicate
dns-format-error? ; -"-
dns-server-failure? ; -"-
dns-name-error? ; -"-
dns-not-implemented? ; -"-
dns-refused? ; -"-
dns-error? ; -"-
bad-nameserver? ; -"-
dns-query/cache ; -"-
add-size-tag
(network-protocol :syntax)
network-protocol?
@ -171,38 +190,67 @@
pretty-print-dns-message
message? message-header message-questions message-answers
make-message message? message-header message-questions message-answers
message-nameservers message-additionals message-source
set-message-source!
make-query-message make-simple-query-message
header? header-flags header-question-count header-answer-count
header-nameserver-count header-additional-count
make-header header? header-id header-flags header-question-count
header-answer-count header-nameserver-count header-additional-count
flags? flags-query-type flags-opcode flags-authoritative?
make-flags flags? flags-query-type flags-opcode flags-authoritative?
flags-truncated? flags-recursion-desired? flags-recursion-available?
flags-zero flags-response-code
flags-zero flags-response-code set-flags-response-code!
set-flags-authoritative! set-flags-recursion-available!
set-flags-truncated!
question? question-name question-type question-class
make-question question? question-name question-type question-class
(message-class :syntax)
message-class? message-class-name message-class-number
the-message-class
message-class-number->type
message-class-symbol->type
(message-type :syntax)
message-type? message-type-name message-type-number
the-message-type
message-type-number->type
message-type-symbol->type
make-resource-record
resource-record?
resource-record-name resource-record-type
resource-record-class resource-record-ttl
resource-record-name
resource-record-type
resource-record-class
resource-record-ttl
resource-record-data
resource-record-data-a? resource-record-data-a-ip
resource-record-data-ns? resource-record-data-ns-name
resource-record-data-cname? resource-record-data-cname-name
resource-record-data-mx? resource-record-data-mx-preference
resource-record-data-mx-exchanger resource-record-data-ptr?
resource-record-data-ptr-name
make-resource-record-data-a
resource-record-data-a?
resource-record-data-a-ip
make-resource-record-data-ns
resource-record-data-ns?
resource-record-data-ns-name
make-resource-record-data-cname
resource-record-data-cname?
resource-record-data-cname-name
make-resource-record-data-mx
resource-record-data-mx?
resource-record-data-mx-preference
resource-record-data-mx-exchanger
make-resource-record-data-ptr
resource-record-data-ptr?
resource-record-data-ptr-name
make-resource-record-data-soa
resource-record-data-soa?
resource-record-data-soa-mname
resource-record-data-soa-rname
@ -212,6 +260,18 @@
resource-record-data-soa-expire
resource-record-data-soa-minimum
make-resource-record-data-aaaa
resource-record-data-aaaa?
resource-record-data-aaaa-ipv6
make-resource-record-data-hinfo
resource-record-data-hinfo?
resource-record-data-hinfo-data
make-resource-record-data-txt
resource-record-data-txt?
resource-record-data-txt-text
cache? cache-answer cache-ttl cache-time
resolv.conf-parse-error?
@ -224,6 +284,7 @@
ip-string->address32
ip-string->in-addr.arpa-string
octet-ip->address32 ;for dns.scm
address32->octet-ip ;for dns.scm
ip-string?))
(define-interface cgi-scripts-interface
@ -266,6 +327,150 @@
(export with-fatal-error-handler*
(with-fatal-error-handler :syntax)))
;; DNS server
(define-interface dnsd-silex-interface
(export lexer
lexer-getc
lexer-ungetc
lexer-init))
(define-interface dnsd-rw-locks-interface
(export make-r/w-lock
obtain-R/w-lock
obtain-r/W-lock
release-R/w-lock
release-r/W-lock
with-R/w-lock
with-r/W-lock))
(define-interface dnsd-semaphores-interface
(export make-semaphore
set-semaphore!
semaphore-post
semaphore-wait))
(define-interface dnsd-mf-parser-interface
(export parse-mf))
(define-interface dnsd-logging-interface
(export display-debug
apply-w/debug
dnsd-log))
(define-interface dnsd-rr-def-interface
(export dns-rr-a
dns-rr-ns
dns-rr-cname
dns-rr-soa
dns-rr-ptr
dns-rr-hinfo
dns-rr-mx
dns-rr-txt
dns-rr-aaaa))
(define-interface dnsd-options-interface
(export make-default-dnsd-options
make-options-from-list
dnsd-options?
dnsd-options-port
dnsd-options-dir
dnsd-options-nameservers
dnsd-options-use-axfr?
dnsd-options-use-cache?
dnsd-options-cleanup-interval
dnsd-options-retry-interval
dnsd-options-use-db?
dnsd-options-use-recursion?
dnsd-options-rec-timeout
dnsd-options-socket-timeout
dnsd-options-socket-max-tries
dnsd-options-max-connections
dnsd-options-blacklist-time
dnsd-options-blacklist-value
dnsd-options-use-pre/post
dnsd-options-debug-mode
with-port
with-dir
with-nameservers
with-axfr
with-cache
with-cleanup-interval
with-retry-interval
with-db
with-recursion
with-rec-timeout
with-socket-timeout
with-socket-max-tries
with-max-connections
with-blacklist-time
with-blacklist-value
with-use-pre/post
with-debug-mode))
(define-interface dnsd-database-interface
(export maybe-get-soa-rr-name
db-clear-database
db-clear-zone
db-update-zone
db-get-zone
db-get-zone-for-axfr
db-get-zone-soa-rr
db-pretty-print
db-lookup-rec))
(define-interface dnsddb-options-interface
(export make-default-dnsddb-options
make-db-options-from-list
dnsddb-options?
dnsddb-options-name
dnsddb-options-class
dnsddb-options-type
dnsddb-options-primary? ;; depreached
dnsddb-options-file
dnsddb-options-filetype
dnsddb-options-master-name
dnsddb-options-master-ip
with-name
with-class
with-type
with-primary?
with-file
with-filetype
with-master-name
with-master-ip))
(define-interface dnsd-cache-interface
(export dnsd-cache-clear!
dnsd-cache-clean!
dnsd-cache-lookup?
dnsd-cache-update!
dnsd-cache-pretty-print))
(define-interface dnsd-slist-interface
(export dnsd-slist-clear!
dnsd-slist-clean!
dnsd-slist-lookup
dnsd-slist-update!
dnsd-slist-pretty-print
dnsd-blacklist-clear!
;deprecated dnsd-blacklist-clean!
dnsd-blacklist!
dnsd-blacklist-unlist!
dnsd-blacklist-print))
(define-interface dnsd-resolver-interface
(export dnsd-ask-resolver-rec
dnsd-ask-resolver-direct
;; Some stuff needed in dnsd.scm:
msg-set-rcode!
make-response))
(define-interface dnsd-interface
(export))
;; FTP server
(define-interface ftpd-interface
@ -425,7 +630,7 @@
(define-structure sunet-version (export sunet-version-identifier)
(open scheme)
(begin
(define sunet-version-identifier "2.0")))
(define sunet-version-identifier "2.1")))
;; Net protocols and formats
@ -536,21 +741,22 @@
(define-structure dns dns-interface
(open scheme-with-scsh
(subset srfi-1 (filter reverse! delete lset-difference lset-union))
(subset srfi-1 (filter reverse! delete lset-difference lset-union
fold fold-right concatenate))
tables
ascii
formats
signals
finite-types
define-record-types
random
queues
conditions
handle
sort
threads
locks
ips)
ips
srfi-27)
(files (lib dns)))
(define-structure ips ips-interface
@ -610,6 +816,159 @@
(open scheme conditions handle)
(files (lib handle-fatal-error)))
;; DNS server ******************************************************************
(define-structure dnsd dnsd-interface
(open scheme-with-scsh
(subset srfi-1 (fold-right take drop filter lset-difference lset-union))
srfi-2
(subset srfi-13 (string-downcase))
threads
thread-fluids ;; fork-thread
rendezvous ; Needs SUnterlib
rendezvous-channels ; Needs SUnterlib
tables
ascii
finite-types
define-record-types
handle-fatal-error
ips ;???
dns
dnsd-options
dnsd-logging
dnsddb-options
;; dnsd-rw-locks
dnsd-semaphores
dnsd-rr-def
dnsd-mf-parser
dnsd-database
dnsd-cache
dnsd-slist
dnsd-resolver)
(files (dnsd dnsd)))
(define-structure dnsd-resolver dnsd-resolver-interface
(open scheme-with-scsh
(subset srfi-1 (fold-right delete filter take drop))
srfi-2
srfi-27 ; for shake-list
threads
thread-fluids ;; fork-thread
rendezvous ; Needs SUnterlib
rendezvous-channels ; Needs SUnterlib
define-record-types
handle-fatal-error
dns
dnsd-cache
dnsd-logging
dnsd-slist
dnsd-options)
(files (dnsd resolver)))
(define-structure dnsd-logging dnsd-logging-interface
(open scheme-with-scsh)
(files (dnsd logging)))
(define-structure dnsddb-options dnsddb-options-interface
(open scheme-with-scsh
define-record-types
dns)
(files (dnsd db-options)))
(define-structure dnsd-database dnsd-database-interface
(open scheme-with-scsh
(subset srfi-1 (fold-right))
srfi-2
(subset srfi-13 (string-downcase))
define-record-types
tables
dns
dnsd-rw-locks
dnsd-logging)
(files (dnsd database)))
(define-structure dnsd-cache dnsd-cache-interface
(open scheme-with-scsh
define-record-types
(subset srfi-1 (fold-right))
(subset srfi-13 (string-downcase))
tables
dns
dnsd-rw-locks)
(files (dnsd cache)))
(define-structure dnsd-slist dnsd-slist-interface
(open scheme-with-scsh
define-record-types
(subset srfi-1 (fold-right filter))
srfi-2
(subset srfi-13 (string-downcase))
tables
dns
dnsd-options
dnsd-rw-locks)
(files (dnsd slist)))
(define-structure dnsd-options dnsd-options-interface
(open scheme-with-scsh
define-record-types)
(files (dnsd options)))
(define-structure dnsd-rw-locks dnsd-rw-locks-interface
(open scheme-with-scsh
locks
threads
define-record-types)
(files (dnsd rw-locks)))
(define-structure dnsd-semaphores dnsd-semaphores-interface
(open scheme-with-scsh
define-record-types
locks)
(files (dnsd semaphores)))
(define-structure dnsd-rr-def dnsd-rr-def-interface
(open scheme-with-scsh
ips
dns
srfi-2)
(files (dnsd rr-def)))
(define-structure dnsd-mf-parser dnsd-mf-parser-interface
(open scheme-with-scsh
(subset srfi-1 (fold-right))
srfi-2
(subset srfi-13 (string-downcase))
handle-fatal-error
dns
dnsd-options
dnsd-logging
dnsd-silex
dnsd-rr-def)
(files (dnsd masterfile-parser)))
(define-structure dnsd-silex dnsd-silex-interface
(open scheme-with-scsh)
(files (dnsd masterfile.l)))
;; FTP server
(define-structure ftpd ftpd-interface

15
web-server/root/surflets/admin-handler.scm
View File

@ -8,7 +8,7 @@
)
(begin
(define (get-option-change return-address update-text options)
(define (get-option-change update-text options)
(send-html/suspend
(lambda (new-url)
`(html
@ -31,14 +31,12 @@
(td ,submit-button))))
options)))
(hr)
(p (url ,(return-address new-url) "Return to adminstration menu.") (br)
(p (url "admin.scm" "Return to adminstration menu.") (br)
(url "/" "Return to main menu."))))
)))
(define submit-timeout (make-submit-button "Change"))
(define return-address (make-address))
(define submit-cache (make-submit-button "Change"))
(define (handler-options req . maybe-update-text)
(let* ((update-text `(font (@ (color "red"))
@ -48,11 +46,9 @@
(cache-checkbox (make-checkbox (options-cache-surflets?)))
(options `(("Current session lifetime: " ,number-field ,submit-timeout)
("Cache SUrflets?" ,cache-checkbox ,submit-cache)))
(req (get-option-change return-address update-text options))
(req (get-option-change update-text options))
(bindings (get-bindings req)))
(cond
((returned-via? return-address bindings)
(return-to-main-page req))
((returned-via? submit-timeout bindings)
(let ((result (input-field-value number-field bindings)))
(if result
@ -74,11 +70,6 @@
(else
(error "unexpected return" bindings)))))
(define (return-to-main-page req)
(send-error (status-code moved-perm) req
"admin.scm" "admin.scm"))
(define (main req)
(handler-options req))

4
web-server/root/surflets/admin-profiling.scm
View File

@ -232,12 +232,12 @@ plot '~a' title 'SUrflet Profiling ~a' with lines"
(if use-convert?
(if (zero? convert-status)
`(image (@ (src ,convert-picture-name)))
`(p "An error occured while generating the profiling results"
`(p "An error occurred while generating the profiling results"
" chart with convert (" ,convert ")."
" Anyway, you can download the "
(url ,gnuplot-picture-name "raw profiling chart") "."))
`(url ,gnuplot-picture-name "Profiling chart."))
`(p "An error occured while generating the profiling results picture."
`(p "An error occurred while generating the profiling results picture."
(br)
"Are you sure, you have " (q "gnuplot")
" installed at " (q ,gnuplot) "?"))

2
web-server/root/surflets/admin.scm
View File

@ -19,6 +19,6 @@
(p (url "/" "Return to main menu.")))))
(define (main req)
(send-html (main-page)))
(send-html/finish (main-page)))
))

2
web-server/root/surflets/calculate-cb.scm
View File

@ -22,7 +22,7 @@
(let ((name (generate-input-field-name "operator")))
(make-input-field
name
(lambda (operator-string)
(lambda (input-field operator-string)
(cond
((assoc operator-string *operator-alist*) =>
(lambda (a) a))

2
web-server/root/surflets/calculate.scm
View File

@ -22,7 +22,7 @@
(let ((name (generate-input-field-name "operator")))
(make-input-field
name "operator"
(lambda (operator-string)
(lambda (input-field operator-string)
(let ((operator (assoc operator-string *operator-alist*)))
(if operator
operator

2
web-server/root/surflets/spaceship.scm
View File

@ -534,7 +534,7 @@ spaceships of class " ,class ":")
(car last)))))))
;;; Does a check on the value of a number-input-field. Abstraction
;;; over two cases occured above. Best explained by the use above.
;;; over two cases occurred above. Best explained by the use above.
(define (check-bounded-number-field class input positiv selector boundary)
(if (or (not input)
(<= input 0))

8
web-server/start-extended-web-server
View File

@ -1,6 +1,6 @@
#!/bin/sh
echo "Loading..."
exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e main -s "$0" "$@"
exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e main -s "$0" "$@"
!#
(define-structure http-test
@ -148,6 +148,10 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
with-syslog? #t
with-log-file (lookup-option options 'log-file-name)
with-post-bind-thunk become-nobody-if-root
;; The following settings are made to avoid dns lookups.
with-reported-port (lookup-option options 'port)
with-fqdn "localhost"
with-resolve-ips? #f
with-request-handler
(alist-path-dispatcher
(list (cons "seval" seval-handler)
@ -167,7 +171,7 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
(lookup-option options 'cgi-bin-dir))))
(tilde-home-dir-handler "public_html"
(rooted-file-or-directory-handler
(lookup-option options htdocs-dir)))))))))
(lookup-option options 'htdocs-dir)))))))))
))
;; EOF

4
web-server/start-surflet-server
View File

@ -1,7 +1,7 @@
#!/bin/sh
echo "Loading..."
exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -e main -s "$0" "$@"
exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -e main -s "$0" "$@"
!#
(define-structure surflet-server
@ -129,7 +129,7 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o surflet-server -
(define (server . args)
(if (pair? args)
(main `(main ,@(car args)))
(main '(main))))
(main (list (cwd)))))
(define (become-nobody-if-root)
(cond ((zero? (user-uid))

6
web-server/start-web-server
View File

@ -1,6 +1,6 @@
#!/bin/sh
echo "Loading..."
exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e main -s "$0" "$@"
exec scsh -lel SSAX-4.9/load.scm -lel module-system/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e main -s "$0" "$@"
!#
(define-structure http-test
@ -140,6 +140,10 @@ exec scsh -lel SSAX-4.9/load.scm -lel sunet-2.1/load.scm -dm -o http-test -e mai
with-syslog? #t
with-log-file (lookup-option options 'log-file-name)
with-post-bind-thunk become-nobody-if-root
;; The following settings are made to avoid dns lookups.
with-reported-port (lookup-option options 'port)
with-fqdn "localhost"
with-resolve-ips? #f
with-request-handler
(alist-path-dispatcher
(list (cons "cgi-bin" (cgi-handler (lookup-option options 'cgi-bin-dir)))